From da160b71e3cac79fd61e65778fd9b409b0520260 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Thu, 7 May 2026 18:20:48 -0400 Subject: [PATCH] passepartout: v0.5.0 File Reorganization Extract non-core fragments using self-repair criterion: - core-context -> symbolic-awareness (224 lines, fboundp guards in think()) - heartbeat generation -> symbolic-events (renamed events-start-heartbeat) Rename 23 files for clarity and new naming scheme: - 6 core: core-package, core-transport, core-pipeline, core-perceive, core-reason, core-act - 13 system: symbolic-*, neuro-*, embedding-*, channel-shell - 4 gateway: channel-cli, channel-tui-*, channel-tui-state Utility relocations: - markdown-strip -> programming-markdown - plist-keywords-normalize -> programming-lisp - cognitive-tool-prompt -> programming-tools - VAULT-MEMORY -> security-vault - Merge *backend-registry* into *probabilistic-backends* Split gateway-messaging into channel-telegram/channel-signal/ channel-discord/channel-slack (4 independent skills) Delete dead system-model.lisp (16-line wrapper) Document self-repair criterion in DESIGN_DECISIONS Version bump: 0.4.3 -> 0.5.0 --- README.org | 2 +- docs/DESIGN_DECISIONS.org | 2 + docs/ROADMAP.org | 67 ++- lisp/gateway-cli.lisp | 35 -- lisp/gateway-tui-main.lisp | 543 ------------------ lisp/gateway-tui-model.lisp | 154 ----- lisp/gateway-tui-view.lisp | 108 ---- lisp/system-integration-tests.lisp | 241 -------- org/{gateway-cli.org => channel-cli.org} | 2 +- org/channel-discord.org | 66 +++ org/channel-shell.org | 135 +++++ org/channel-signal.org | 57 ++ org/channel-slack.org | 61 ++ org/channel-telegram.org | 63 ++ ...eway-tui-main.org => channel-tui-main.org} | 8 +- ...ay-tui-model.org => channel-tui-state.org} | 10 +- ...eway-tui-view.org => channel-tui-view.org} | 4 +- org/{core-loop-act.org => core-act.org} | 2 +- org/core-defpackage.org | 321 ----------- org/core-package.org | 98 ++++ ...re-loop-perceive.org => core-perceive.org} | 2 +- org/{core-loop.org => core-pipeline.org} | 5 +- org/{core-loop-reason.org => core-reason.org} | 124 +--- org/core-skills.org | 3 +- ...e-communication.org => core-transport.org} | 4 +- org/embedding-backends.org | 305 ++++++++++ org/embedding-native.org | 361 ++++++++++++ org/gateway-messaging.org | 193 ------- org/neuro-explorer.org | 155 +++++ org/neuro-provider.org | 234 ++++++++ org/neuro-router.org | 223 +++++++ org/symbolic-archivist.org | 381 ++++++++++++ org/symbolic-awareness.org | 383 ++++++++++++ org/symbolic-config.org | 383 ++++++++++++ org/symbolic-diagnostics.org | 294 ++++++++++ org/symbolic-events.org | 350 +++++++++++ org/symbolic-memory.org | 92 +++ org/symbolic-scope.org | 343 +++++++++++ org/symbolic-self-improve.org | 280 +++++++++ org/system-integration-tests.org | 504 ---------------- passepartout | 8 +- passepartout.asd | 21 +- 42 files changed, 4374 insertions(+), 2253 deletions(-) delete mode 100644 lisp/gateway-cli.lisp delete mode 100644 lisp/gateway-tui-main.lisp delete mode 100644 lisp/gateway-tui-model.lisp delete mode 100644 lisp/gateway-tui-view.lisp delete mode 100644 lisp/system-integration-tests.lisp rename org/{gateway-cli.org => channel-cli.org} (97%) create mode 100644 org/channel-discord.org create mode 100644 org/channel-shell.org create mode 100644 org/channel-signal.org create mode 100644 org/channel-slack.org create mode 100644 org/channel-telegram.org rename org/{gateway-tui-main.org => channel-tui-main.org} (99%) rename org/{gateway-tui-model.org => channel-tui-state.org} (96%) rename org/{gateway-tui-view.org => channel-tui-view.org} (98%) rename org/{core-loop-act.org => core-act.org} (99%) delete mode 100644 org/core-defpackage.org create mode 100644 org/core-package.org rename org/{core-loop-perceive.org => core-perceive.org} (99%) rename org/{core-loop.org => core-pipeline.org} (99%) rename org/{core-loop-reason.org => core-reason.org} (79%) rename org/{core-communication.org => core-transport.org} (99%) create mode 100644 org/embedding-backends.org create mode 100644 org/embedding-native.org create mode 100644 org/neuro-explorer.org create mode 100644 org/neuro-provider.org create mode 100644 org/neuro-router.org create mode 100644 org/symbolic-archivist.org create mode 100644 org/symbolic-awareness.org create mode 100644 org/symbolic-config.org create mode 100644 org/symbolic-diagnostics.org create mode 100644 org/symbolic-events.org create mode 100644 org/symbolic-memory.org create mode 100644 org/symbolic-scope.org create mode 100644 org/symbolic-self-improve.org delete mode 100644 org/system-integration-tests.org diff --git a/README.org b/README.org index a037990..84f36c8 100644 --- a/README.org +++ b/README.org @@ -3,7 +3,7 @@ #+FILETAGS: :passepartout:ai:assistant: #+HTML:
-#+HTML: +#+HTML: #+HTML: #+HTML: #+HTML: diff --git a/docs/DESIGN_DECISIONS.org b/docs/DESIGN_DECISIONS.org index 6bba653..95ec3a5 100644 --- a/docs/DESIGN_DECISIONS.org +++ b/docs/DESIGN_DECISIONS.org @@ -440,4 +440,6 @@ The critical risk is implementation: achieving the retrieval precision, Dispatch 5. *Competitor evolution.* Sparse retrieval is not patentable. Claude Code, Copilot, and others will implement similar mechanisms. The architectural advantage is real but finite in duration. The deterministic safety gate is the harder-to-replicate differentiator. +6. *The self-repair criterion.* "What belongs in core?" is decided by a single test: if this file is corrupted, can the agent fix it without human help? Corrupted core = dead brain, dead hands, or unreachable. Corrupted skill = degraded but self-repairable. If the agent has tools, identity, and user input, it can reason about missing awareness, edit the corrupted source file, reload the skill, and continue. If it loses its own reasoning loop, it has no way to self-diagnose. This is why context assembly and heartbeat generation were extracted to skills in v0.5.0 — the agent can detect their absence and reload them. The core contracts to the absolute minimum needed for self-repair: the pipeline, the memory, the transport, and the skill loader. + diff --git a/docs/ROADMAP.org b/docs/ROADMAP.org index a373a2d..7faada8 100644 --- a/docs/ROADMAP.org +++ b/docs/ROADMAP.org @@ -741,7 +741,7 @@ Rationale: The current file naming scheme mixes three concerns: architectural ro The criterion: a file belongs in core if, when corrupted, the agent cannot fix it without human help. Corrupted core = dead brain, dead hands, or unreachable. Corrupted skill = degraded but self-repairable. -*** TODO Extract core-context → symbolic-awareness +*** DONE Extract core-context → symbolic-awareness :PROPERTIES: :ID: id-v050-reorg-awareness :CREATED: [2026-05-07 Thu] @@ -755,7 +755,7 @@ Rationale: ~core-context.lisp~ (224 lines) handles ~context-assemble-global-awar - Remove ~core-context~ from ~passepartout.asd~ ~:components~. - FiveAM: verify ~think()~ produces valid output when awareness skill is not loaded. -*** TODO Extract heartbeat generation → symbolic-events +*** DONE Extract heartbeat generation → symbolic-events :PROPERTIES: :ID: id-v050-reorg-heartbeat :CREATED: [2026-05-07 Thu] @@ -768,7 +768,7 @@ Rationale: The heartbeat thread (~heartbeat-start~, ~*heartbeat-thread*~, auto-s - In ~core-pipeline.lisp~'s ~main()~: change ~(heartbeat-start)~ to ~(when (fboundp 'events-start-heartbeat) (events-start-heartbeat))~. - ~symbolic-events~ already processes ~:heartbeat~ signals for cron dispatch (existing code). Now it also generates them. -*** TODO Relocate 6 utility fragments to correct files +*** DONE Relocate 6 utility fragments to correct files :PROPERTIES: :ID: id-v050-reorg-utilities :CREATED: [2026-05-07 Thu] @@ -783,7 +783,7 @@ Rationale: Several functions live in core files not because they need core prote - ~VAULT-MASK-STRING~ + ~*VAULT-MEMORY*~ (core-skills.lisp) → ~security-vault.lisp~. - ~*backend-registry*~ dedup: merge with ~*probabilistic-backends*~ (core-reason.lisp:10-12), remove ~backend-register~ (core-reason.lisp:18-19), update ~backend-cascade-call~ to check only one hash table. -*** TODO Rename 6 core files — shorter, clearer names +*** DONE Rename 6 core files — shorter, clearer names :PROPERTIES: :ID: id-v050-reorg-core-names :CREATED: [2026-05-07 Thu] @@ -799,7 +799,7 @@ Rename mapping: Update: ASDF ~:components~, all ~:tangle~ headers in ~.org~ files, cross-file references, ~README.org~, ~ARCHITECTURE.org~, ~AGENTS.md~, ~*dispatcher-protected-paths*~ (wildcard ~core-*~ still matches — no change needed). -*** TODO Rename 13 system-* → symbolic-/neuro-/embedding-* +*** DONE Rename 13 system-* → symbolic-/neuro-/embedding-* :PROPERTIES: :ID: id-v050-reorg-system-names :CREATED: [2026-05-07 Thu] @@ -820,11 +820,11 @@ Rename mapping: - ~system-model-embedding-native~ → ~embedding-native~ - ~system-actuator-shell~ → ~channel-shell~ -*** TODO Delete ~system-model.lisp~ (16-line wrapper) +*** DONE Delete ~system-model.lisp~ (16-line wrapper) The file delegates to ~*probabilistic-backends*~ — dead code. No skill references it directly. -*** TODO Rename 4 gateway-* → channel-* +*** DONE Rename 4 gateway-* → channel-* :PROPERTIES: :ID: id-v050-reorg-channel-names :CREATED: [2026-05-07 Thu] @@ -838,7 +838,7 @@ Rename mapping: Update TUI package name: ~passepartout.gateway-tui~ → ~passepartout.channel-tui~. -*** TODO Split ~gateway-messaging~ → 4 ~channel-*~ files +*** DONE Split ~gateway-messaging~ → 4 ~channel-*~ files :PROPERTIES: :ID: id-v050-reorg-messaging-split :CREATED: [2026-05-07 Thu] @@ -852,7 +852,7 @@ Rationale: ~gateway-messaging.lisp~ (411 lines) bundles 4 independent platforms. - ~channel-slack~: Events API + ~chat.postMessage~. Replace hardcoded channel IDs. ~register-actuator :slack~. - Delete ~gateway-messaging.lisp~. Update ~DEFSKILL-FROM-ORG~ references in ~system-config~ setup wizard. -*** TODO Document core/non-core self-repair criterion +*** DONE Document core/non-core self-repair criterion :PROPERTIES: :ID: id-v050-reorg-docs :CREATED: [2026-05-07 Thu] @@ -884,6 +884,55 @@ After all renames complete, update every remaining reference: *** Verify: ASDF compiles, FiveAM suite passes, integration tests pass. +*** Time Awareness — Temporal Context for the Agent + +Rationale: Passepartout already has the infrastructure for time awareness — timestamped memory (v0.1.0), heartbeat+cron (v0.3.0), and foveal-peripheral context pruning (v0.2.0). Adding time awareness costs ~175 lines of Lisp and unlocks three layers that no competitor provides. The temporal dimension is the missing axis in the foveal-peripheral model: prune in time as well as in semantic space. + +*** TODO Time Awareness — Level 2: temporal memory filtering +:PROPERTIES: +:ID: id-v050-time-memory +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: ~memory-object-version~ has been set to ~get-universal-time~ on every ingest since v0.1.0. Every memory node carries a timestamp. But ~context-query~ has no time filter — "what did I work on today?" serializes all nodes to the LLM instead of filtering 500→12 in sub-millisecond Lisp. + +- ~memory-objects-since(timestamp)~ in ~core-memory.lisp~: hash-table walk returning objects with ~version >= timestamp~. ~20 lines. +- ~memory-objects-in-range(since until)~ in ~core-memory.lisp~: version between two timestamps. ~15 lines. +- Extend ~context-query~ in ~symbolic-awareness.lisp~ with ~:since~ and ~:until~ keyword parameters. ~10 lines. +- Pure Lisp, sub-millisecond, 0 LLM tokens. ~90% token reduction on time-scoped memory queries. +- FiveAM test: ingest 3 nodes at T0, sleep, ingest 2 nodes at T1, verify ~memory-objects-since(T1)~ returns exactly 2. + +*** TODO Time Awareness — Level 3: ~sensor-time~ skill +:PROPERTIES: +:ID: id-v050-sensor-time +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: The heartbeat fires every 60 seconds for maintenance tasks. It can also carry temporal awareness — scanning for approaching deadlines, tracking session duration, and injecting temporal context so the LLM knows "3 deadlines today: Submit report (45min)" without triggering a call. This turns "what should I do today?" from a 1,500–4,000 token LLM call into a 0-token pre-loaded context answer. + +- New skill: ~sensor-time.org~ → ~sensor-time.lisp~. ~120 lines. +- Session tracking: record session start time at load. Expose ~(session-duration)~. +- Cron-registered heartbeat tick: ~orchestrator-register-cron "time-tick"~ with ~:action sensor-time-tick~, ~:tier :reflex~ (no LLM), ~:repeat "+1m"~. +- Deadline scanning on tick: query memory for headlines with ~:DEADLINE~ or ~:SCHEDULED~ properties. If within ~DEADLINE_WARNING_MINUTES~ (env var, default 60), inject deadline note into awareness context. +- Deadline context note format: ~"3 deadlines approaching: Submit report (45min), Review PR (2h), Call mom (3h)."~ +- ~TUI status bar~: add session duration and deadline count to the status bar (reuse existing gate-trace / focus-map rendering from v0.4.0). +- FiveAM test: set deadline 30 minutes from now, fire tick, verify deadline appears in awareness context. + +*** TODO Time Awareness — Level 1: timestamp in system prompt +:PROPERTIES: +:ID: id-v050-time-prompt +:CREATED: [2026-05-07 Thu] +:END: + +Rationale: The system prompt currently has IDENTITY, TOOLS, CONTEXT, LOGS. No TIME. The LLM cannot answer "what time is it?" or contextualize deadlines correctly. Adding a timestamp costs ~8 incremental tokens and eliminates guessing, time-check tool calls, and preamble hedging. Combined with session duration from Level 3, the LLM knows "2026-05-07 Thu 14:32:17 UTC. Session: 3h 12m." + +- ~format-time-for-llm~ function: returns human-readable date + time + optional session duration. Uses ~multiple-value-bind~ with ~decode-universal-time~. ~15 lines. +- Inject into ~think()~'s system prompt format string in ~core-reason.lisp~: add ~TIME:~ section between IDENTITY and TOOLS. ~5 lines. +- ~TIME_AWARENESS~ env var (default ~true~) in ~.env.example~. When ~false~, timestamp omitted. +- ~TIME_FORMAT~ env var (default ~iso~): ~iso~ = ~2026-05-07T14:32:17Z~, ~natural~ = ~2:32 PM UTC, Thursday May 7, 2026~. +- Session duration from ~session-duration~ function in ~sensor-time~ skill (Level 3). If skill not loaded, omit duration, show time only. +- FiveAM test: ~format-time-for-llm~ returns string containing current year and UTC; with ~TIME_AWARENESS=false~ returns empty string. + *** Token Economics (foundation complete — now build features) **Design insight: why token economics is the structural differentiator.** Passepartout's sparse-tree rendering and deterministic safety gates should produce 2–3x fewer tokens than competitors for equivalent coding tasks, and 13–24x fewer for knowledge management. But without caching and budget enforcement, the fixed overhead per call eats these savings. A coding session that touches 30 files with competent context management costs ~72K tokens (Passepartout) versus ~185K (Claude Code). Without caching, the Passepartout number climbs toward ~150K because every call retransmits the static prefix. The architectural advantage exists in theory but requires operational plumbing to materialize. diff --git a/lisp/gateway-cli.lisp b/lisp/gateway-cli.lisp deleted file mode 100644 index 27290f1..0000000 --- a/lisp/gateway-cli.lisp +++ /dev/null @@ -1,35 +0,0 @@ -(in-package :passepartout) - -(defun gateway-cli-input (text) - "Processes raw text from the command line." - (inject-stimulus (list :type :EVENT - :payload (list :sensor :user-input :text text) - :meta (list :source :CLI)))) - -(defskill :passepartout-gateway-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-gateway-cli-tests - (:use :cl :passepartout) - (:export #:cli-suite)) - -(in-package :passepartout-gateway-cli-tests) - -(fiveam:def-suite cli-suite :description "Verification of the CLI Gateway") -(fiveam:in-suite cli-suite) - -(fiveam:test test-gateway-cli-input-format - "Contract 1: gateway-cli-input injects a properly formed signal without error." - (handler-case - (progn (gateway-cli-input "hello") (fiveam:pass)) - (error (c) - (fiveam:fail "gateway-cli-input crashed: ~a" c)))) - -(handler-case - (progn (gateway-cli-input "test-load") (log-message "CLI: Load-time test OK")) - (error (c) (log-message "CLI: Load-time test FAILED: ~a" c))) diff --git a/lisp/gateway-tui-main.lisp b/lisp/gateway-tui-main.lisp deleted file mode 100644 index f0e6c93..0000000 --- a/lisp/gateway-tui-main.lisp +++ /dev/null @@ -1,543 +0,0 @@ -(in-package :passepartout.gateway-tui) - -(defun on-key (&rest args) - ;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for - ;; backspace). Croatoan's code-key + key-name convert them to keywords - ;; so the cond below can use eq. - (let* ((raw (car args)) - (ch (if (and (integerp raw) (> raw 255)) - (let* ((k (code-key raw)) - (name (and k (key-name k)))) - (or name raw)) - raw))) - (cond - ;; Enter - ((or (eq ch :enter) (eql ch 13) (eql ch 10) - (eql ch #\Newline) (eql ch #\Return)) - ;; Multi-line: if buffer ends with \, strip it and insert newline - (if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\)) - (progn (pop (st :input-buffer)) - (push #\Newline (st :input-buffer)) - (setf (st :dirty) (list nil nil t))) - (let ((text (string-trim '(#\Space #\Tab) (input-string)))) - (when (> (length text) 0) - (push text (st :input-history)) - (setf (st :input-hpos) 0) - (setf (st :scroll-offset) 0) - (cond - ;; /help command - ((string-equal text "/help") - (add-msg :system - "/eval Evaluate Lisp expression") - (add-msg :system - "/focus Set project context") - (add-msg :system - "/scope Change scope (memex/session/project)") - (add-msg :system - "/unfocus Pop context stack") - (add-msg :system - "/theme Show current color theme") - (add-msg :system - "/help Show this help") - (add-msg :system - "\\ + Enter Multi-line input")) - ;; /theme command - ((string-equal text "/theme") - (add-msg :system - (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a" - *tui-theme-current-name* - (getf *tui-theme* :user) - (getf *tui-theme* :agent) - (getf *tui-theme* :system) - (getf *tui-theme* :input)) - (format nil "Presets: /theme dark | light | solarized | gruvbox"))) - ((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: dark light solarized gruvbox" name))))) - ;; /eval command - ((and (>= (length text) 6) - (string-equal (subseq text 0 6) "/eval ")) - (handler-case - (let* ((*read-eval* t) - (*package* (find-package :passepartout.gateway-tui)) - (r (eval (read-from-string (subseq text 6))))) - (add-msg :system (format nil "=> ~s" r))) - (error (c) (add-msg :system (format nil "=> ✗ ~a" c))))) - ;; /focus — 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) - (connect-daemon)) - ;; 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 - ((or (eql ch 9) (eq ch :tab)) - (let ((text (input-string))) - (cond - ((and (>= (length text) 8) - (string-equal (subseq text 0 7) "/theme ")) - (let* ((partial (subseq text 7)) - (names '("dark" "light" "solarized" "gruvbox")) - (match (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))))) - ((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 #\Backspace)) - (input-delete-char) - (setf (st :dirty) (list nil nil t))) - ;; Left arrow - ((or (eq ch :left) (eql ch 260)) - (when (> (or (st :cursor-pos) 0) 0) - (decf (st :cursor-pos)) - (setf (st :dirty) (list nil nil t)))) - ;; Right arrow - ((or (eq ch :right) (eql ch 261)) - (when (< (or (st :cursor-pos) 0) (length (st :input-buffer))) - (incf (st :cursor-pos)) - (setf (st :dirty) (list nil nil t)))) - ;; Up arrow - ((or (eq ch :up) (eql ch 259)) - (let* ((h (st :input-history)) (p (st :input-hpos))) - (when (and h (< p (1- (length h)))) - (incf (st :input-hpos)) - (setf (st :input-buffer) - (reverse (coerce (nth (st :input-hpos) h) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; Down arrow - ((or (eq ch :down) (eql ch 258)) - (when (> (st :input-hpos) 0) - (decf (st :input-hpos)) - (let ((h (st :input-history))) - (setf (st :input-buffer) - (if (and h (< (st :input-hpos) (length h))) - (reverse (coerce (nth (st :input-hpos) h) 'list)) - nil)) - (setf (st :dirty) (list nil nil t))))) - ;; PageUp - ((or (eq ch :ppage) (eql ch 339)) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 5)))) - (setf (st :dirty) (list nil t nil))) - ;; PageDown - ((or (eq ch :npage) (eql ch 338)) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5))) - (setf (st :dirty) (list nil t nil))) - ;; Printable - (t - (let ((chr (typecase ch - (character ch) - (integer (code-char ch)) - (t nil)))) - (when (and chr (graphic-char-p chr)) - (input-insert-char chr) - (setf (st :dirty) (list nil nil t)))))))) - -(defun on-daemon-msg (msg) - (let* ((payload (getf msg :payload)) - (text (getf payload :text)) - (action (getf payload :action)) - (gate-trace (getf msg :gate-trace)) - (rule-count (getf payload :rule-count)) - (foveal-id (getf payload :foveal-id))) - (when rule-count (setf (st :rule-count) rule-count)) - (when foveal-id (setf (st :foveal-id) foveal-id)) - (cond - (text (setf (st :busy) nil) - (add-msg :agent text :gate-trace gate-trace)) - ((eq action :handshake) - (add-msg :system (format nil "Connected v~a" (getf payload :version)))) - (t (add-msg :agent (format nil "~a" msg)))))) - -(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") (port 9105)) - (add-msg :system "* Connecting to daemon... *") - (loop for attempt from 1 to 3 - for backoff = 0 then 3 - do (sleep backoff) - (handler-case - (let ((s (usocket:socket-connect host port :timeout 5))) - (setf (st :stream) (usocket:socket-stream s) - (st :connected) t) - (bt:make-thread (lambda () (reader-loop (st :stream))) - :name "tui-reader") - (add-msg :system (format nil "* Connected v~a *" "0.4.0")) - (return-from connect-daemon t)) - (usocket:connection-refused-error (c) - (when (= attempt 3) - (add-msg :system (format nil "* No daemon on port ~a after ~a attempts *" - port attempt)))) - (error (c) - (add-msg :system (format nil "* Connection attempt ~a failed: ~a *" - attempt c)) - (when (= attempt 3) - (add-msg :system "* TIP: run 'passepartout daemon' first *"))))) - nil) - -(defun disconnect-daemon () - (when (st :stream) - (ignore-errors (close (st :stream))) - (setf (st :stream) nil (st :connected) nil) - (add-msg :system "* Disconnected *"))) - -(defun tui-main () - (init-state) - (load-history) - (theme-load) - (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) - (let* ((h (or (height scr) 24)) - (w (or (width scr) 80)) - (sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1)) - (ch (- h 5)) - (cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1)) - (iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1)) - (swank-port (or (ignore-errors - (parse-integer (uiop:getenv "TUI_SWANK_PORT"))) - 4006))) - (setf (function-keys-enabled-p iw) t - (input-blocking iw) nil - (st :dirty) (list t t t) - ;; Store windows in state for SIGWINCH handler - (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw) - (connect-daemon) - (when (> swank-port 0) - (handler-case - (progn - (ql:quickload :swank :silent t) - (funcall (find-symbol "CREATE-SERVER" "SWANK") - :port swank-port :dont-close t) - (add-msg :system - (format nil "* Swank ~d M-x slime-connect *" swank-port))) - (error () - (add-msg :system "* Swank unavailable *")))) - ;; Initial render before the main loop — otherwise the screen stays - ;; blank until the first keystroke (get-char blocks). - (redraw sw cw ch iw) - (refresh scr) - (loop while (st :running) do - (dolist (ev (drain-queue)) - (cond - ((eq (getf ev :type) :daemon) - (on-daemon-msg (getf ev :payload))) - ((eq (getf ev :type) :disconnected) - (setf (st :connected) nil - (st :busy) nil) - (add-msg :system "* Connection lost — type /reconnect to retry *")))) - (let ((ch (get-char iw))) - (cond - ((or (not ch) (equal ch -1)) nil) - ;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses) - ((eql ch 410) - (let* ((new-h (or (height scr) 24)) - (new-w (or (width scr) 80)) - (new-ch (- new-h 5))) - (setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1) - ch new-ch - cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1) - iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1) - w new-w - h new-h) - (setf (function-keys-enabled-p iw) t - (input-blocking iw) nil - (st :dirty) (list t t t) - (st :sw) sw (st :cw) cw (st :iw) iw) - (redraw sw cw ch iw) - (refresh scr))) - (t (on-key ch)))) - (redraw sw cw ch iw) - (refresh scr) - (sleep 0.03)) - (disconnect-daemon)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tui-tests - (:use :cl :passepartout :passepartout.gateway-tui) - (:export #:tui-suite)) - -(in-package :passepartout-tui-tests) - -(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling") -(fiveam:in-suite tui-suite) - -(fiveam:test test-init-state - "Contract model.1: init-state returns fresh state plist with required keys." - (init-state) - (fiveam:is (eq t (st :running))) - (fiveam:is (eq :chat (st :mode))) - (fiveam:is (eq nil (st :connected))) - (fiveam:is (eq nil (st :stream))) - (fiveam:is (eq nil (st :messages))) - (fiveam:is (eq 0 (st :scroll-offset))) - (fiveam:is (eq nil (st :busy)))) - -(fiveam:test test-add-msg - "Contract model.2: add-msg appends a message with role, content, and time." - (init-state) - (add-msg :user "hello") - (let* ((msgs (st :messages)) - (msg (first msgs))) - (fiveam:is (eq :user (getf msg :role))) - (fiveam:is (string= "hello" (getf msg :content))) - (fiveam:is (stringp (getf msg :time))) - (fiveam:is (= 5 (length (getf msg :time)))))) - -(fiveam:test test-add-msg-dirty-flag - "Contract model.2: add-msg sets dirty flags for status and chat." - (init-state) - (setf (st :dirty) (list nil nil nil)) - (add-msg :system "boot") - (let ((dirty (st :dirty))) - (fiveam:is (eq t (first dirty))) - (fiveam:is (eq t (second dirty))) - (fiveam:is (eq nil (third dirty))))) - -(fiveam:test test-queue-event-roundtrip - "Contract model.3: queue-event + drain-queue preserves events in order." - (init-state) - (queue-event '(:type :key :payload (:ch 13))) - (queue-event '(:type :daemon :payload (:text "hi"))) - (let ((evs (drain-queue))) - (fiveam:is (= 2 (length evs))) - (fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs))) - (fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs))) - (fiveam:is (null (drain-queue))))) - -(fiveam:test test-on-key-enter-sends-user-message - "Contract 1: on-key with Enter extracts input, adds user message, clears buffer." - (init-state) - ;; Simulate typing "test" - (dolist (ch '(#\t #\e #\s #\t)) - (on-key (char-code ch))) - (fiveam:is (string= "test" (input-string))) - ;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled - (on-key 343) - ;; Input buffer should be cleared - (fiveam:is (string= "" (input-string))) - ;; A user message should be in the message list - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 1)) - (let ((last (first msgs))) - (fiveam:is (eq :user (getf last :role))) - (fiveam:is (string= "test" (getf last :content)))))) - -(fiveam:test test-on-key-eval-command - "Contract 1: on-key handles /eval command and displays result." - (init-state) - ;; Type "/eval (+ 1 2)" - (dolist (ch (coerce "/eval (+ 1 2)" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 1)) - (let ((last-msg (first msgs))) - (fiveam:is (eq :system (getf last-msg :role))) - (fiveam:is (search "=> 3" (getf last-msg :content)))))) - -(fiveam:test test-on-key-backspace - "Contract 1: on-key with Backspace removes last character from buffer." - (init-state) - (dolist (ch '(#\a #\b #\c)) - (on-key (char-code ch))) - (fiveam:is (string= "abc" (input-string))) - ;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled - (on-key 263) - (fiveam:is (string= "ab" (input-string)))) - -(fiveam:test test-on-key-focus-command - "Contract 1: /focus command parses project name." - (init-state) - (dolist (ch (coerce "/focus myapp" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (first (st :messages)))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-scope-command - "Contract 1: /scope command with valid argument." - (init-state) - (dolist (ch (coerce "/scope memex" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (first (st :messages)))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-unfocus-command - "Contract 1: /unfocus command dispatches correctly." - (init-state) - (dolist (ch (coerce "/unfocus" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (first (st :messages)))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-tab-completion - "Contract 1: Tab completes / commands when input starts with /." - (init-state) - (dolist (ch (coerce "/ev" 'list)) - (on-key (char-code ch))) - (on-key 9) - (fiveam:is (string= "/eval " (input-string)))) - -(fiveam:test test-on-key-tab-no-slash - "Contract 1: Tab does nothing when input doesn't start with /." - (init-state) - (dolist (ch (coerce "hello" 'list)) - (on-key (char-code ch))) - (on-key 9) - (fiveam:is (string= "hello" (input-string)))) - -(fiveam:test test-on-key-multiline - "Contract 1: \\ + Enter inserts newline instead of sending." - (init-state) - (dolist (ch (coerce "line1" 'list)) - (on-key (char-code ch))) - (on-key (char-code #\\)) - (on-key 343) - (fiveam:is (search "line1" (input-string))) - (fiveam:is (search (string #\Newline) (input-string)))) - -(fiveam:test test-on-key-help - "Contract 1: /help displays command list." - (init-state) - (dolist (ch (coerce "/help" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 3)) - (fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs)))) - -(fiveam:test test-activity-indicator - "Contract model: :busy flag is set on send and cleared on agent response." - (init-state) - (fiveam:is (eq nil (st :busy))) - ;; Simulate sending a normal message (sets busy) - (dolist (ch (coerce "hello" 'list)) - (on-key (char-code ch))) - (on-key 343) - (fiveam:is (eq t (st :busy))) - ;; Simulate receiving an agent response (clears busy) - (on-daemon-msg '(:type :event :payload (:text "hi back"))) - (fiveam:is (eq nil (st :busy)))) - -(fiveam:test test-theme - "Contract view: *tui-theme* provides color mappings." - (fiveam:is (eq :green (getf *tui-theme* :user))) - (fiveam:is (eq :white (getf *tui-theme* :agent))) - (fiveam:is (eq :yellow (getf *tui-theme* :system))) - (fiveam:is (eq :cyan (getf *tui-theme* :input))) - (fiveam:is (eq :white (theme-color :unknown-role)))) diff --git a/lisp/gateway-tui-model.lisp b/lisp/gateway-tui-model.lisp deleted file mode 100644 index 5e2cdaa..0000000 --- a/lisp/gateway-tui-model.lisp +++ /dev/null @@ -1,154 +0,0 @@ -(defpackage :passepartout.gateway-tui - (:use :cl :croatoan :passepartout :usocket :bordeaux-threads) - (:export :tui-main :st :add-msg :now :input-string - :queue-event :drain-queue :init-state - :view-status :view-chat :view-input :redraw - :on-key :on-daemon-msg :send-daemon - :connect-daemon :disconnect-daemon - :*tui-theme* :theme-color)) -(in-package :passepartout.gateway-tui) - -(defvar *state* nil) -(defvar *event-queue* nil) -(defvar *event-lock* (bt:make-lock "tui-event-lock")) - -(defvar *tui-theme* - ;; Roles - '(:user :green :agent :white :system :yellow - ;; Content - :input :cyan :timestamp :yellow :help :cyan :error :red :warning :yellow - ;; Status - :connected :green :disconnected :red :busy :magenta :idle :white - ;; Gate trace - :gate-passed :green :gate-blocked :red :gate-approval :yellow - ;; Tools (future use) - :tool-running :magenta :tool-success :green :tool-failure :red :tool-output :white - ;; Display - :scroll-indicator :cyan :border :white :background :black - ;; Differentiator (v0.4.0) - :rule-count :cyan :focus-map :yellow - ;; UI - :dim :white :highlight :cyan :accent :green) - "Color theme plist. 27 semantic keys → Croatoan color values. -See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") - -(defvar *tui-theme-presets* - '(:dark (:user :green :agent :white :system :yellow - :input :cyan :timestamp :yellow :help :cyan :error :red :warning :yellow - :connected :green :disconnected :red :busy :magenta :idle :white - :gate-passed :green :gate-blocked :red :gate-approval :yellow - :tool-running :magenta :tool-success :green :tool-failure :red :tool-output :white - :scroll-indicator :cyan :border :white :background :black - :rule-count :cyan :focus-map :yellow - :dim :white :highlight :cyan :accent :green) - :light (:user :blue :agent :black :system :red - :input :black :timestamp :yellow :help :blue :error :red :warning :yellow - :connected :green :disconnected :red :busy :magenta :idle :black - :gate-passed :green :gate-blocked :red :gate-approval :yellow - :tool-running :magenta :tool-success :green :tool-failure :red :tool-output :black - :scroll-indicator :blue :border :black :background :white - :rule-count :blue :focus-map :red - :dim :white :highlight :blue :accent :green) - :gruvbox (:user "#458588" :agent "#ebdbb2" :system "#fabd2f" - :input "#ebdbb2" :timestamp "#928374" :help "#83a598" :error "#fb4934" :warning "#fabd2f" - :connected "#b8bb26" :disconnected "#fb4934" :busy "#d3869b" :idle "#a89984" - :gate-passed "#b8bb26" :gate-blocked "#fb4934" :gate-approval "#fabd2f" - :tool-running "#d3869b" :tool-success "#b8bb26" :tool-failure "#fb4934" :tool-output "#ebdbb2" - :scroll-indicator "#83a598" :border "#a89984" :background "#282828" - :rule-count "#83a598" :focus-map "#fabd2f" - :dim "#928374" :highlight "#83a598" :accent "#b8bb26") - :solarized (:user "#268bd2" :agent "#839496" :system "#b58900" - :input "#839496" :timestamp "#93a1a1" :help "#2aa198" :error "#dc322f" :warning "#b58900" - :connected "#859900" :disconnected "#dc322f" :busy "#d33682" :idle "#657b83" - :gate-passed "#859900" :gate-blocked "#dc322f" :gate-approval "#b58900" - :tool-running "#d33682" :tool-success "#859900" :tool-failure "#dc322f" :tool-output "#839496" - :scroll-indicator "#2aa198" :border "#657b83" :background "#002b36" - :rule-count "#2aa198" :focus-map "#b58900" - :dim "#586e75" :highlight "#2aa198" :accent "#859900")) - "Named theme presets. /theme loads one into *tui-theme*.") - -(defvar *tui-theme-current-name* :dark - "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.gateway-tui::*tui-theme* '~s)~%" *tui-theme*) - (format out "(setf passepartout.gateway-tui::*tui-theme-current-name* ~s)~%" *tui-theme-current-name*)) - t)) - -(defun theme-load () - "Load persisted theme from disk. Called at startup." - (let ((path (merge-pathnames ".cache/passepartout/theme.lisp" - (user-homedir-pathname)))) - (when (uiop:file-exists-p path) - (ignore-errors (load path))))) - -(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 the Croatoan color for a semantic role." - (or (getf *tui-theme* role) :white)) - -(defun st (key) (getf *state* key)) -(defun (setf st) (val key) (setf (getf *state* key) val)) - -(defun init-state () - (setf *state* - (list :running t :mode :chat :connected nil :stream nil - :input-buffer nil :input-history nil :input-hpos 0 - :messages (make-array 16 :adjustable t :fill-pointer 0) - :scroll-offset 0 :busy nil :cursor-pos 0 - :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) - (vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace) (st :messages)) - (setf (st :dirty) (list t t nil))) - -(defun queue-event (ev) - (bt:with-lock-held (*event-lock*) (push ev *event-queue*))) - -(defun drain-queue () - (bt:with-lock-held (*event-lock*) - (let ((evs (nreverse *event-queue*))) - (setf *event-queue* nil) evs))) diff --git a/lisp/gateway-tui-view.lisp b/lisp/gateway-tui-view.lisp deleted file mode 100644 index e8fbe3f..0000000 --- a/lisp/gateway-tui-view.lisp +++ /dev/null @@ -1,108 +0,0 @@ -(in-package :passepartout.gateway-tui) - -(defun view-status (win) - (clear win) - (box win 0 0) - (add-string win - (format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a" - (if (st :connected) "● Connected" "○ Disconnected") - (string-upcase (string (st :mode))) - (length (st :messages)) - (if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0") - (or (st :rule-count) 0) - (if (st :busy) " …thinking" "")) - :y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected))) - ;; Second line: Focus map - (let ((focus-info (or (st :foveal-id) ""))) - (when (and focus-info (> (length focus-info) 0)) - (add-string win (format nil " [Focus: ~a]" focus-info) - :y 2 :x 1 :fgcolor (theme-color :timestamp)))) - (add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp)) - (refresh win)) - -(defun word-wrap (text width) - "Break text into lines at word boundaries, each <= width chars. -Returns list of trimmed strings. Single words wider than width are split." - (let ((lines '()) - (pos 0) - (len (length text))) - (loop while (< pos len) - do (let ((end (min len (+ pos width)))) - (cond - ((>= end len) - (push (string-trim '(#\Space) (subseq text pos len)) lines) - (setf pos len)) - ((char= (char text (1- end)) #\Space) - (push (string-trim '(#\Space) (subseq text pos end)) lines) - (setf pos end)) - (t - (let ((last-space (position #\Space text :from-end t :end (1+ end) :start pos))) - (if (and last-space (> last-space pos)) - (progn - (push (string-trim '(#\Space) (subseq text pos last-space)) lines) - (setf pos (1+ last-space))) - (progn - (push (string-trim '(#\Space) (subseq text pos end)) lines) - (setf pos end)))))))) - (nreverse lines))) - -(defun view-chat (win h) - (clear win) - (box win 0 0) - (let* ((w (or (width win) 78)) - (msgs (st :messages)) - (total (length msgs)) - (max-lines (- h 2)) - (y 1)) - ;; Count visible messages from end, accounting for word wrap - (let* ((msg-count 0) - (lines-remaining max-lines)) - (loop for i from (1- total) downto 0 - while (> lines-remaining 0) - do (let* ((msg (aref msgs i)) - (role (getf msg :role)) - (content (getf msg :content)) - (time (or (getf msg :time) "")) - (prefix (case role (:user "⬆") (:agent "⬇") (t " "))) - (line-text (format nil "~a [~a] ~a" prefix time content)) - (wrapped (word-wrap line-text (- w 2))) - (nlines (length wrapped))) - (if (<= nlines lines-remaining) - (progn (decf lines-remaining nlines) (incf msg-count)) - (setf lines-remaining 0)))) - ;; Render from the correct starting message - (let* ((scroll-skip (st :scroll-offset)) - (start (max 0 (- total msg-count scroll-skip)))) - (loop for i from start below total - while (< y (1- h)) - do (let* ((msg (aref msgs i)) - (role (getf msg :role)) - (content (getf msg :content)) - (time (or (getf msg :time) "")) - (color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent)))) - (prefix (case role (:user "⬆") (:agent "⬇") (t " "))) - (line-text (format nil "~a [~a] ~a" prefix time content)) - (wrapped (word-wrap line-text (- w 2)))) - (dolist (line wrapped) - (when (< y (1- h)) - (add-string win line :y y :x 1 :n (1- w) :fgcolor color) - (incf y)))))))) - (refresh win)) - -(defun view-input (win) - (let* ((text (input-string)) - (w (or (width win) 78)) - (pos (or (st :cursor-pos) 0)) - (display-start (max 0 (- pos (1- w)))) - (visible (subseq text display-start (min (length text) (+ display-start w))))) - (clear win) - (add-string win (format nil "~a " visible) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input)) - (setf (cursor-position win) (list 0 (min (- pos display-start) (1- w))))) - (refresh win)) - -(defun redraw (sw cw ch iw) - (destructuring-bind (sd cd id) (st :dirty) - (when sd (view-status sw)) - (when cd (view-chat cw ch)) - (when id (view-input iw)) - (setf (st :dirty) (list nil nil nil)))) diff --git a/lisp/system-integration-tests.lisp b/lisp/system-integration-tests.lisp deleted file mode 100644 index 2004786..0000000 --- a/lisp/system-integration-tests.lisp +++ /dev/null @@ -1,241 +0,0 @@ -(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/org/gateway-cli.org b/org/channel-cli.org similarity index 97% rename from org/gateway-cli.org rename to org/channel-cli.org index b54a4e4..61ebf11 100644 --- a/org/gateway-cli.org +++ b/org/channel-cli.org @@ -1,7 +1,7 @@ #+TITLE: SKILL: CLI Gateway (org-skill-cli-gateway.org) #+AUTHOR: Agent #+FILETAGS: :skill:gateway:cli: -#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-cli.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-cli.lisp * Overview The CLI Gateway is the simplest interface to Passepartout — raw stdin/stdout over TCP. It connects to the daemon's framed protocol and translates between terminal input/output and the plist-based communication format. No TUI, no ncurses, no dependencies beyond a TCP socket. Every other gateway (TUI, Emacs, Telegram) builds on this same protocol. diff --git a/org/channel-discord.org b/org/channel-discord.org new file mode 100644 index 0000000..b3b649a --- /dev/null +++ b/org/channel-discord.org @@ -0,0 +1,66 @@ +#+TITLE: Channel Discord (channel-discord.org) +#+AUTHOR: Agent +#+FILETAGS: :channel:discord: +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-discord.lisp + +* Channel Discord + +Extracted from gateway-messaging in v0.5.0. Isolated platform — Discord-specific poll and send logic. + +* Implementation + +#+begin_src lisp +(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)))))) +#+end_src + + +#+end_src diff --git a/org/channel-shell.org b/org/channel-shell.org new file mode 100644 index 0000000..34f5439 --- /dev/null +++ b/org/channel-shell.org @@ -0,0 +1,135 @@ +#+TITLE: SKILL: Shell Actuator (org-skill-shell-actuator.org) +#+AUTHOR: Agent +#+FILETAGS: :skill:actuator:shell: +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-shell.lisp + +* Overview: The Physical Actuator + +The Shell Actuator is the agent's hand in the physical world. Given a shell command, it executes it via ~bash -c~ and returns the output. This is how the agent installs packages, reads files, runs scripts, and interacts with any Unix tool. + +Because shell execution is the highest-risk operation in the system, the Shell Actuator is protected by multiple safety layers: +1. The Dispatcher's shell safety gate blocks destructive commands (~rm -rf /~, ~dd~, ~mkfs~) +2. The Dispatcher's injection gate blocks backtick and ~$()~ patterns +3. The Dispatcher's network exfil gate blocks connections to unwhitelisted hosts +4. The actuator enforces a timeout (default 30s) so hanging commands don't freeze the agent +5. The actuator caps output (default 100KB) so infinite output doesn't exhaust memory +6. (v0.4.3) When ~bwrap~ (Bubblewrap) is available, commands execute inside a Linux namespace sandbox with network and IPC isolation + +** Contract + +1. (bwrap-available-p): returns T if ~bwrap~ is installed and usable, NIL otherwise. + Cached at load time via ~which bwrap~. +2. (bwrap-wrap-command cmd timeout memex-dir): returns a command list suitable for + ~uiop:run-program~ — wraps ~cmd~ in a ~bwrap~ sandbox with ~--unshare-net~, + ~--unshare-ipc~, ~--ro-bind~ for system dirs, and ~--bind~ for the memex and /tmp. +3. (actuator-shell-execute action context): when ~bwrap~ is available, wraps the + command through the sandbox. When ~bwrap~ is unavailable, falls back to the + existing ~timeout bash -c~ behavior. + +* Implementation + +** Shell Execution (actuator-shell-execute) +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(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))))))) +#+end_src + +** Skill Registration +#+begin_src lisp +(register-actuator :shell #'actuator-shell-execute) + +(defskill :passepartout-system-actuator-shell + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) +#+end_src + +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-shell-actuator-tests + (:use :cl :fiveam :passepartout) + (:export #:shell-actuator-suite)) + +(in-package :passepartout-shell-actuator-tests) + +(def-suite shell-actuator-suite :description "Verification of the Shell Actuator") +(in-suite shell-actuator-suite) + +(test test-bwrap-wrap-command + "Contract 2: bwrap-wrap-command returns properly formatted command list." + (let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex"))) + (is (member "bwrap" cmdline :test #'string=)) + (is (member "--unshare-net" cmdline :test #'string=)) + (is (member "--unshare-ipc" cmdline :test #'string=)) + (is (member "echo hello" cmdline :test #'string=)))) + +(test test-bwrap-available-p-returns-boolean + "Contract 1: bwrap-available-p returns T or NIL." + (let ((avail (passepartout::bwrap-available-p))) + (is (typep avail 'boolean)))) + +(test test-actuator-shell-execute-echo + "Contract 3: actuator-shell-execute runs echo and returns output." + (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello"))) + (result (passepartout::actuator-shell-execute action nil))) + (is (stringp result)) + (is (search "hello" result :test #'char-equal)))) +#+end_src diff --git a/org/channel-signal.org b/org/channel-signal.org new file mode 100644 index 0000000..616aadc --- /dev/null +++ b/org/channel-signal.org @@ -0,0 +1,57 @@ +#+TITLE: Channel Signal (channel-signal.org) +#+AUTHOR: Agent +#+FILETAGS: :channel:signal: +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-signal.lisp + +* Channel Signal + +Extracted from gateway-messaging in v0.5.0. Isolated platform — Signal-specific poll and send logic. + +* Implementation + +#+begin_src lisp +(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)))))) +#+end_src + + +#+end_src diff --git a/org/channel-slack.org b/org/channel-slack.org new file mode 100644 index 0000000..14014f0 --- /dev/null +++ b/org/channel-slack.org @@ -0,0 +1,61 @@ +#+TITLE: Channel Slack (channel-slack.org) +#+AUTHOR: Agent +#+FILETAGS: :channel:slack: +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-slack.lisp + +* Channel Slack + +Extracted from gateway-messaging in v0.5.0. Isolated platform — Slack-specific poll and send logic. + +* Implementation + +#+begin_src lisp +(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))))))) +#+end_src + + +#+end_src diff --git a/org/channel-telegram.org b/org/channel-telegram.org new file mode 100644 index 0000000..df6545e --- /dev/null +++ b/org/channel-telegram.org @@ -0,0 +1,63 @@ +#+TITLE: Channel Telegram (channel-telegram.org) +#+AUTHOR: Agent +#+FILETAGS: :channel:telegram: +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-telegram.lisp + +* Channel Telegram + +Extracted from gateway-messaging in v0.5.0. Isolated platform — Telegram-specific poll and send logic. + +* Implementation + +#+begin_src lisp +(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)))))) +#+end_src + + +#+end_src diff --git a/org/gateway-tui-main.org b/org/channel-tui-main.org similarity index 99% rename from org/gateway-tui-main.org rename to org/channel-tui-main.org index fb73c5e..96705c8 100644 --- a/org/gateway-tui-main.org +++ b/org/channel-tui-main.org @@ -1,5 +1,5 @@ #+TITLE: Passepartout TUI — Controller -#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-main.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-tui-main.lisp * Controller @@ -29,7 +29,7 @@ Event handlers + daemon I/O + main loop. ** Event Handlers #+begin_src lisp -(in-package :passepartout.gateway-tui) +(in-package :passepartout.channel-tui) (defun on-key (&rest args) ;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for @@ -93,7 +93,7 @@ Event handlers + daemon I/O + main loop. (string-equal (subseq text 0 6) "/eval ")) (handler-case (let* ((*read-eval* t) - (*package* (find-package :passepartout.gateway-tui)) + (*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))))) @@ -410,7 +410,7 @@ Event handlers + daemon I/O + main loop. (ql:quickload :fiveam :silent t)) (defpackage :passepartout-tui-tests - (:use :cl :passepartout :passepartout.gateway-tui) + (:use :cl :passepartout :passepartout.channel-tui) (:export #:tui-suite)) (in-package :passepartout-tui-tests) diff --git a/org/gateway-tui-model.org b/org/channel-tui-state.org similarity index 96% rename from org/gateway-tui-model.org rename to org/channel-tui-state.org index 763908d..8c93096 100644 --- a/org/gateway-tui-model.org +++ b/org/channel-tui-state.org @@ -1,5 +1,5 @@ #+TITLE: Passepartout TUI — Model -#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-model.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-tui-state.lisp * Model @@ -18,7 +18,7 @@ All state mutation flows through event handlers in the controller. ** Package + State #+begin_src lisp -(defpackage :passepartout.gateway-tui +(defpackage :passepartout.channel-tui (:use :cl :croatoan :passepartout :usocket :bordeaux-threads) (:export :tui-main :st :add-msg :now :input-string :queue-event :drain-queue :init-state @@ -26,7 +26,7 @@ All state mutation flows through event handlers in the controller. :on-key :on-daemon-msg :send-daemon :connect-daemon :disconnect-daemon :*tui-theme* :theme-color)) -(in-package :passepartout.gateway-tui) +(in-package :passepartout.channel-tui) (defvar *state* nil) (defvar *event-queue* nil) @@ -97,8 +97,8 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") (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.gateway-tui::*tui-theme* '~s)~%" *tui-theme*) - (format out "(setf passepartout.gateway-tui::*tui-theme-current-name* ~s)~%" *tui-theme-current-name*)) + (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 () diff --git a/org/gateway-tui-view.org b/org/channel-tui-view.org similarity index 98% rename from org/gateway-tui-view.org rename to org/channel-tui-view.org index f3562d6..cd14c18 100644 --- a/org/gateway-tui-view.org +++ b/org/channel-tui-view.org @@ -1,5 +1,5 @@ #+TITLE: Passepartout TUI — View -#+PROPERTY: header-args:lisp :tangle ../lisp/gateway-tui-view.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/channel-tui-view.lisp * View @@ -38,7 +38,7 @@ All three enrichments cost 0 LLM tokens — they are daemon-state queries that the TUI actuator attaches to the response plist before transmission. #+begin_src lisp -(in-package :passepartout.gateway-tui) +(in-package :passepartout.channel-tui) (defun view-status (win) (clear win) diff --git a/org/core-loop-act.org b/org/core-act.org similarity index 99% rename from org/core-loop-act.org rename to org/core-act.org index 53fa7e4..183faf8 100644 --- a/org/core-loop-act.org +++ b/org/core-act.org @@ -2,7 +2,7 @@ #+AUTHOR: Agent #+FILETAGS: :harness:act: #+STARTUP: content -#+PROPERTY: header-args:lisp :tangle ../lisp/core-loop-act.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/core-act.lisp * Overview: Architectural Intent diff --git a/org/core-defpackage.org b/org/core-defpackage.org deleted file mode 100644 index 4f3fdf2..0000000 --- a/org/core-defpackage.org +++ /dev/null @@ -1,321 +0,0 @@ -#+TITLE: Core: Package Definition (core-defpackage.org) -#+AUTHOR: Agent -#+FILETAGS: :passepartout:core:defpackage: -#+STARTUP: content -#+PROPERTY: header-args:lisp :tangle ../lisp/core-defpackage.lisp - -* Overview: Architectural Intent - -~package.lisp~ defines two things: the public API of the ~passepartout~ package (the export list), and the implementation of low-level utility functions and global state that don't belong in a specific pipeline stage or skill. - -The export list is the contract between the harness and all skills. Every function exported here is accessible to every skill via ~use-package~. Adding a symbol here is an API commitment; removing one is a breaking change. - -The implementation section includes: -- ~plist-get~ — robust plist accessor used everywhere in the pipeline -- Logging state (~*log-buffer*~, ~*log-lock*~) — bounded ring buffer for LLM context -- Skill registry (~*skill-registry*~, ~defskill~) — all loaded skills live here -- Cognitive tool registry (~*cognitive-tool-registry*~, ~def-cognitive-tool~, ~cognitive-tool-prompt~) -- Telemetry tracking (~*telemetry-table*~, ~telemetry-track~) — performance metrics per skill -- Debugger hook — replaces raw SBCL debugger with a friendly error message - -* Implementation - -** Package Definition and Export List -The package definition. All public symbols are exported here. -#+begin_src lisp -(defpackage :passepartout - (:use :cl) - (:export - #:frame-message - #:read-framed-message - #:PROTO-GET - #:proto-get - #:*VAULT-MEMORY* - #:make-hello-message - #:validate-communication-protocol-schema - #:start-daemon - #:log-message - #:main - #:diagnostics-run-all - #:diagnostics-main - #:diagnostics-dependencies-check - #:diagnostics-env-check - #:register-provider - #:provider-openai-request - #:provider-config - #:run-setup-wizard - #:ingest-ast - #:memory-object-get - #:*memory-store* - #:memory-object - #:make-memory-object - #:memory-object-id - #:memory-object-type - #:memory-object-attributes - #:memory-object-parent-id - #:memory-object-children - #:memory-object-version - #:memory-object-last-sync - #:memory-object-vector - #:memory-object-content - #:memory-object-hash - #:memory-object-scope - #:snapshot-memory - #:rollback-memory - #:context-get-system-logs - #:context-assemble-global-awareness - #:context-awareness-assemble - #:context-query - #:push-context - #:pop-context - #:current-context - #:current-scope - #:context-stack-depth - #:context-save - #:context-load - #:focus-project - #:focus-session - #:focus-memex - #:unfocus - #:process-signal - #:loop-process - #:perceive-gate - #:loop-gate-perceive - #:act-gate - #:loop-gate-act - #:reason-gate - #:loop-gate-reason - #:cognitive-verify - #:backend-cascade-call - #:json-alist-to-plist - #:inject-stimulus - #:stimulus-inject - #:hitl-create - #:hitl-approve - #:hitl-deny - #:hitl-handle-message - #:dispatcher-check-secret-path - #:dispatcher-check-shell-safety - #:dispatcher-check-privacy-tags - #:dispatcher-check-network-exfil - #:dispatcher-gate - #:wildcard-match - #:actuator-initialize - #:action-dispatch - #:register-actuator - #:load-skill-from-org - #:skill-initialize-all - #:lisp-syntax-validate - #:defskill - #:*skill-registry* - #:*scope-resolver* - #:*embedding-backend* - #:*embedding-queue* - #:*embedding-provider* - #:embed-queue-object - #:embed-object - #:embed-all-pending - #:embedding-backend-hashing - #:embedding-backend-native - #:embedding-native-load-model - #:embedding-native-unload - #:embedding-native-ensure-loaded - #:embedding-native-get-dim - #:embeddings-compute - #:mark-vector-stale - #:skill - #:skill-name - #:skill-priority - #:skill-dependencies - #:skill-trigger-fn - #:skill-probabilistic-prompt - #:skill-deterministic-fn - #:def-cognitive-tool - #:*cognitive-tool-registry* - #:org-read-file - #:org-write-file - #:org-headline-add - #:org-headline-find-by-id - #:literate-tangle-sync-check - #:archivist-create-note - #:gateway-start - #:org-property-set - #:org-todo-set - #:org-id-generate - #:org-id-format - #:org-modify - #:lisp-validate - #:lisp-structural-check - #:lisp-syntactic-check - #:lisp-semantic-check - #:lisp-eval - #:lisp-format - #:lisp-list-definitions - #:lisp-extract - #:lisp-inject - #:lisp-slurp - #:get-oc-config-dir - #:get-tool-permission - #:set-tool-permission - #:check-tool-permission-gate - #:permission-get - #:permission-set - #:cognitive-tool - #:cognitive-tool-name - #:cognitive-tool-description - #:cognitive-tool-parameters - #:cognitive-tool-guard - #:cognitive-tool-body - #:register-probabilistic-backend - #:*probabilistic-backends* - #:*provider-cascade* - #:vault-get - #:vault-set - #:vault-get-secret - #:vault-set-secret - #:memory-objects-by-attribute - #:gateway-cli-input - #:repl-eval - #:repl-inspect - #:repl-list-vars - #:policy-compliance-check - #:validator-protocol-check - #:archivist-extract-headlines - #:archivist-headline-to-filename - #:literate-extract-lisp-blocks - #:literate-block-balance-check - #:gateway-registry-initialize - #:messaging-link - #:messaging-unlink - #:gateway-configured-p)) -#+end_src - -** Package Implementation -The package implementation section defines the low-level utilities and global state that are shared across all harness components and skills. - -*** Robust plist access (plist-get) -Retrieves a value from a plist, checking both upper and lowercase keyword variants. This is needed because different components use different keyword conventions. -#+begin_src lisp -(in-package :passepartout) - -(defun plist-get (plist key) - "Robust plist accessor — checks both :KEY and :key variants." - (let* ((s (string key)) - (up (intern (string-upcase s) :keyword)) - (dn (intern (string-downcase s) :keyword))) - (or (getf plist up) (getf plist dn)))) -#+end_src - -*** Logging state -The harness maintains a bounded ring buffer of log messages for inclusion in LLM context. Access is thread-safe via a lock. -#+begin_src lisp -(defvar *log-buffer* nil) -(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock")) -(defvar *log-limit* 100) -#+end_src - -*** Skill registry -The global registry of all loaded skills. This is the authoritative list that the deterministic engine iterates. -#+begin_src lisp -(defvar *skill-registry* (make-hash-table :test 'equal) - "Global registry of all loaded skills.") -#+end_src - -*** Skill telemetry -Tracks execution metrics per skill (count, duration, failures) for diagnostics and performance analysis. -#+begin_src lisp -(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))))) -#+end_src - -*** Cognitive tool registry -Tools that the LLM can invoke are registered here. Each tool has a name, description, parameters, optional guard, and implementation body. The ~def-cognitive-tool~ macro handles registration. ~cognitive-tool-prompt~ serialises the registry into the LLM's system prompt. -#+begin_src lisp -(defvar *cognitive-tool-registry* (make-hash-table :test 'equal)) -#+end_src - -#+begin_src lisp -(defstruct cognitive-tool - name - description - parameters - guard - body) -#+end_src - -#+begin_src lisp -(defmacro def-cognitive-tool (name description parameters &key guard body) - "Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter." - `(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*) - (make-cognitive-tool :name (string-downcase (string ',name)) - :description ,description - :parameters ',parameters - :guard ,guard - :body ,body))) -#+end_src - -#+begin_src lisp -(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)) -#+end_src - -*** Centralized logging (log-message) -Thread-safe logging function that writes to both the ring buffer (for LLM context) and stdout (for the user). Bounded by ~*log-limit*~. -#+begin_src lisp -(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))) -#+end_src - -*** Debugger hook -Friendly error handler that replaces the raw SBCL debugger with a diagnostic message. This prevents the agent from entering the debugger on unhandled conditions. -#+begin_src lisp -(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))) -#+end_src diff --git a/org/core-package.org b/org/core-package.org new file mode 100644 index 0000000..2985569 --- /dev/null +++ b/org/core-package.org @@ -0,0 +1,98 @@ +#+TITLE: Core: Package Definition (core-package.org) +#+AUTHOR: Agent +#+FILETAGS: :passepartout:core:defpackage: +#+STARTUP: content +#+PROPERTY: header-args:lisp :tangle ../lisp/core-package.lisp + +* Overview: Architectural Intent + +~package.lisp~ defines two things: the public API of the ~passepartout~ package (the export list), and the implementation of low-level utility functions and global state that don't belong in a specific pipeline stage or skill. + +The export list is the contract between the harness and all skills. Every function exported here is accessible to every skill via ~use-package~. Adding a symbol here is an API commitment; removing one is a breaking change. + +The implementation section includes: +- ~plist-get~ — robust plist accessor used everywhere in the pipeline +- Logging state (~*log-buffer*~, ~*log-lock*~) — bounded ring buffer for LLM context +- Skill registry (~*skill-registry*~, ~defskill~) — all loaded skills live here +- Cognitive tool registry (~*cognitive-tool-registry*~, ~def-cognitive-tool~, ~cognitive-tool-prompt~) +- Telemetry tracking (~*telemetry-table*~, ~telemetry-track~) — performance metrics per skill +- Debugger hook — replaces raw SBCL debugger with a friendly error message + +* Implementation + + +#+begin_src lisp +(defstruct cognitive-tool + name + description + parameters + guard + body) +#+end_src + +#+begin_src lisp +(defmacro def-cognitive-tool (name description parameters &key guard body) + "Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter." + `(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*) + (make-cognitive-tool :name (string-downcase (string ',name)) + :description ,description + :parameters ',parameters + :guard ,guard + :body ,body))) +#+end_src + +#+begin_src lisp +(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)) +#+end_src + +*** Centralized logging (log-message) +Thread-safe logging function that writes to both the ring buffer (for LLM context) and stdout (for the user). Bounded by ~*log-limit*~. +#+begin_src lisp +(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))) +#+end_src + +*** Debugger hook +Friendly error handler that replaces the raw SBCL debugger with a diagnostic message. This prevents the agent from entering the debugger on unhandled conditions. +#+begin_src lisp +(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))) +#+end_src diff --git a/org/core-loop-perceive.org b/org/core-perceive.org similarity index 99% rename from org/core-loop-perceive.org rename to org/core-perceive.org index b803aaf..4aa73ef 100644 --- a/org/core-loop-perceive.org +++ b/org/core-perceive.org @@ -2,7 +2,7 @@ #+AUTHOR: Agent #+FILETAGS: :harness:perceive: #+STARTUP: content -#+PROPERTY: header-args:lisp :tangle ../lisp/core-loop-perceive.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/core-perceive.lisp * Overview: Architectural Intent diff --git a/org/core-loop.org b/org/core-pipeline.org similarity index 99% rename from org/core-loop.org rename to org/core-pipeline.org index 05a2b46..2a6285f 100644 --- a/org/core-loop.org +++ b/org/core-pipeline.org @@ -2,7 +2,7 @@ #+AUTHOR: Agent #+FILETAGS: :harness:loop: #+STARTUP: content -#+PROPERTY: header-args:lisp :tangle ../lisp/core-loop.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/core-pipeline.lisp * Overview: Architectural Intent @@ -284,7 +284,8 @@ Boot sequence: ;; Run proactive diagnostics before starting services (diagnostics-startup-run) - (heartbeat-start) + (when (fboundp 'events-start-heartbeat) + (events-start-heartbeat)) (start-daemon) #+sbcl diff --git a/org/core-loop-reason.org b/org/core-reason.org similarity index 79% rename from org/core-loop-reason.org rename to org/core-reason.org index f849c4e..39d4fa7 100644 --- a/org/core-loop-reason.org +++ b/org/core-reason.org @@ -2,93 +2,22 @@ #+AUTHOR: Agent #+FILETAGS: :harness:reason: #+STARTUP: content -#+PROPERTY: header-args:lisp :tangle ../lisp/core-loop-reason.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/core-reason.lisp * Overview: Architectural Intent The Reason stage is the cognitive heart of Passepartout. It takes a normalized signal from Perceive and produces an approved action for Act. This is where the two engines — probabilistic (LLM) and deterministic (Lisp logic) — collaborate. -The design is shaped by one non-negotiable constraint: **the LLM must never touch the actuators directly.** Every action the LLM proposes must pass through a deterministic verification gate that has the final say. This is what separates Passepartout from every other AI agent: the creative brain suggests, but the logical brain decides. - -** The Probabilistic-Deterministic Split - -An LLM is a statistical engine. Given enough context, it is remarkably good at translation, generation, and pattern matching. But it cannot be trusted with authority because hallucination is a *fundamental property* of probabilistic inference — the model generates the most likely continuation, not the correct one. - -The deterministic engine addresses this by being what the probabilistic engine is not: mathematically rigorous, formally verifiable, and incapable of hallucination by design. It operates on explicit symbolic representations — lists, property lists, knowledge graphs — not on floating-point activations. When it evaluates a path confinement check, it returns true or false, not a probability distribution. - -The division of labor is architectural: -- The LLM handles the fuzzy interface between human language and structured representation -- The deterministic engine receives those structured representations and evaluates them against formal invariants -- The LLM never reads a file, never executes a command, never modifies memory — it generates proposals - -This separation is the source of Passepartout's safety guarantee. Other agents add "guardrails" as an afterthought — a layer of filtering around a dangerous core. Passepartout makes the division explicit. - -** Why Plists for Communication? - -Every message in the Reason pipeline is a property list (plist): - - (TYPE :REQUEST TARGET :CLI PAYLOAD (ACTION :MESSAGE TEXT "Hello")) - -A plist is simultaneously: -- Human-readable text -- Machine-parseable data structure -- Executable Lisp code - -This is not a cosmetic choice. It means the reasoning pipeline can generate, modify, and execute its own communication protocol without external parsing libraries. There is no JSON encoder, no schema validator, no serialization layer between the two engines. They speak the same language because they *are* the same language. - -** Contract - -1. (cognitive-verify proposed-action context): runs all registered - deterministic gates sorted by priority. Returns a rejection plist - (~:LOG~ or ~:EVENT~) if any gate blocks the action, an - ~:approval-required~ event if a gate requires HITL, or the action - (potentially modified) if it passes. -2. (loop-gate-reason signal): the full reason pipeline — only processes - ~:user-input~ and ~:chat-message~ sensors. Runs ~think~ to generate - a candidate, then ~cognitive-verify~ to gate it. Retries up to 3 - times on rejection. Sets ~:status :reasoned~ on completion. -3. (reason-gate signal): thin alias for ~loop-gate-reason~. -4. (backend-cascade-call prompt): iterates ~*provider-cascade*~ calling - each backend's handler until one succeeds. Returns the LLM content - string, or a ~:LOG~ failure if all backends are exhausted. -5. (json-alist-to-plist alist): converts a JSON alist (from - ~cl-json:decode-json-from-string~) to a keyword-prefixed plist. - String keys → upcased keywords. Nested alists recurse into plists. - JSON arrays (lists whose first element is not a cons) pass through. - Scalars and nil pass through. - -* Implementation - -** Package Context -#+begin_src lisp -(in-package :passepartout) -#+end_src - -** Probabilistic Backend Registry - -~*probabilistic-backends*~ is a hash table mapping provider keywords to -their handler functions. Populated by ~register-probabilistic-backend~. -Skills like system-model-provider register into this table at boot time. - -;; REPL-VERIFIED: 2026-05-03T14:00:00 -#+begin_src lisp -(defvar *probabilistic-backends* (make-hash-table :test 'equal) - "Maps provider keyword → handler function (prompt system-prompt &key model).") - -(defun register-probabilistic-backend (name fn) - "Register FN as the handler for provider NAME." - (setf (gethash name *probabilistic-backends*) fn)) -#+end_src - +The design is shaped by one non-negotiable constraint: **the LLM must never touch the actuators directly. The probabilistic engine maintains four pieces of global state that control how LLM requests are dispatched: -~*backend-registry*~ is a hash table mapping provider keywords (like ~:ollama~ or ~:openrouter~) to the actual function that calls that provider's API. ~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus. +~*probabilistic-backends*~ is a hash table mapping provider keywords (like ~:ollama~ or ~:openrouter~) to the actual function that calls that provider's API. ~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus. These variables are configurable at runtime. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))). ;; REPL-VERIFIED: 2026-05-03T13:00:00 #+begin_src lisp -(defvar *backend-registry* (make-hash-table :test 'equal)) +(defvar *probabilistic-backends* (make-hash-table :test 'equal)) #+end_src ** Provider Cascade @@ -112,18 +41,6 @@ These variables are configurable at runtime. The cascade can be changed without (defvar *consensus-enabled* nil) #+end_src -** Backend Registration (backend-register) - -Each LLM provider registers itself by calling this function. The backend function receives a prompt string, a system prompt string, and optional keyword arguments for model selection. It must return either a plist with ~:status :success~ and ~:content~, or ~:status :error~ with a message. - -Registration is typically done at boot time by the unified-llm-backend skill, but can also be done dynamically: - (backend-register :my-custom-provider #'my-fn) - -;; REPL-VERIFIED: 2026-05-03T13:00:00 -#+begin_src lisp -(defun backend-register (name fn) - (setf (gethash name *backend-registry*) fn)) -#+end_src ** Cascade Dispatch (backend-cascade-call) @@ -148,7 +65,7 @@ This is deliberately resilient. The system should never crash because an LLM pro (dolist (backend backends (or result (list :type :LOG :payload (list :text "Neural Cascade Failure: All providers exhausted.")))) - (let ((backend-fn (or (gethash backend *backend-registry*) + (let ((backend-fn (or (gethash backend *probabilistic-backends*) (gethash backend *probabilistic-backends*)))) (when backend-fn (log-message "PROBABILISTIC: Attempting backend ~a..." backend) @@ -192,21 +109,6 @@ The LLM might wrap its output in Markdown code fences (~```~). This function str text)) #+end_src -** Normalize plist keywords - -Lisp keywords are case-sensitive. The LLM might produce ~:payload~ or ~:PAYLOAD~ or ~:Payload~ depending on the model. This function normalizes all keyword keys to uppercase to ensure the deterministic engine receives consistent input. - -;; REPL-VERIFIED: 2026-05-03T13:00:00 -#+begin_src lisp -(defun plist-keywords-normalize (plist) - (when (listp plist) - (loop for (k v) on plist by #'cddr - collect (if (and (symbolp k) (not (keywordp k))) - (intern (string k) :keyword) - k) - collect v))) -#+end_src - ** Think: assemble context and call the LLM This is the main entry point for the probabilistic engine. Every cognitive cycle goes through here. @@ -223,8 +125,12 @@ The system prompt assembly order — identity (including mandates), tools, conte (defun think (context) (let* ((active-skill (find-triggered-skill context)) (tool-belt (generate-tool-belt-prompt)) - (global-context (context-assemble-global-awareness)) - (system-logs (context-get-system-logs)) + (global-context (if (fboundp 'context-assemble-global-awareness) + (context-assemble-global-awareness) + "No context awareness available. (symbolic-awareness skill not loaded)")) + (system-logs (if (fboundp 'context-get-system-logs) + (context-get-system-logs) + (list "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))) @@ -528,8 +434,8 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r (test test-backend-cascade-with-mock "Contract 4: backend-cascade-call returns content from first successful backend." - (let ((passepartout::*backend-registry* (make-hash-table :test 'equal))) - (setf (gethash :mock-backend passepartout::*backend-registry*) + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))) + (setf (gethash :mock-backend passepartout::*probabilistic-backends*) (lambda (prompt sp &key model) (declare (ignore prompt sp model)) (list :status :success :content "mock-response"))) @@ -538,9 +444,9 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r (test test-read-eval-rce-blocked "Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code." - (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)) + (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) (passepartout::*provider-cascade* '(:mock-evil))) - (setf (gethash :mock-evil passepartout::*backend-registry*) + (setf (gethash :mock-evil passepartout::*probabilistic-backends*) (lambda (prompt sp &key model) (declare (ignore prompt sp model)) (list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))"))) diff --git a/org/core-skills.org b/org/core-skills.org index bb2cd2c..dbb7458 100644 --- a/org/core-skills.org +++ b/org/core-skills.org @@ -67,8 +67,7 @@ Simple mask function and the vault memory hash table. Used by the Security Dispa #+begin_src lisp (defun VAULT-MASK-STRING (s) (declare (ignore s)) "[MASKED]") -(defvar *VAULT-MEMORY* (make-hash-table :test 'equal)) -#+end_src +( ** Skill data structures diff --git a/org/core-communication.org b/org/core-transport.org similarity index 99% rename from org/core-communication.org rename to org/core-transport.org index cf52653..2d7ddd8 100644 --- a/org/core-communication.org +++ b/org/core-transport.org @@ -2,7 +2,7 @@ #+AUTHOR: Agent #+FILETAGS: :harness:protocol: #+STARTUP: content -#+PROPERTY: header-args:lisp :tangle ../lisp/core-communication.lisp +#+PROPERTY: header-args:lisp :tangle ../lisp/core-transport.lisp * Overview: Architectural Intent @@ -151,7 +151,7 @@ The daemon sends a handshake message on connection, then enters a read loop, inj (let ((stream (usocket:socket-stream socket))) (handler-case (progn - (format stream "~a" (frame-message (make-hello-message "0.4.3"))) + (format stream "~a" (frame-message (make-hello-message "0.5.0"))) (finish-output stream) (loop (let ((msg (read-framed-message stream))) diff --git a/org/embedding-backends.org b/org/embedding-backends.org new file mode 100644 index 0000000..056f918 --- /dev/null +++ b/org/embedding-backends.org @@ -0,0 +1,305 @@ +#+TITLE: SKILL: Embedding Gateway (org-skill-embedding-gateway.org) +#+AUTHOR: Agent +#+FILETAGS: :skill:system:embedding: +#+PROPERTY: header-args:lisp :tangle ../lisp/embedding-backends.lisp + +* Architectural Intent + +~system-model-embedding~ converts text into vector representations for semantic search and memory retrieval. It provides three backends: + +- ~:trigram~ — a zero-dependency fallback that uses character-trigram Jaccard similarity. Pure Lisp, works fully offline, captures lexical overlap. +- ~:sha256~ — integrity-only (explicit opt-in). SHA-256 hashing for environments where even trivial computation is undesirable. +- ~:local~ — any OpenAI-compatible ~/api/embeddings~ endpoint (Ollama, vLLM, etc.) +- ~:openai~ — the OpenAI ~/v1/embeddings~ API with an API key +- ~:native~ — in-process inference via llama.cpp / CFFI. 768-dim nomic-embed-text-v1.5, zero network calls, <100ms per document on CPU. Requires model file at ~/.local/share/passepartout/models/nomic-embed-text-v1.5.Q4_K_M.gguf and libllama_wrap.so at /usr/local/lib. + +The embedding queue (~embed-queue-object~ / ~embed-all-pending~) decouples document indexing from the main loop. On each heartbeat tick, ~embed-all-pending~ drains the queue and embeds all accumulated objects. This prevents indexing traffic from blocking conversational responses. + +The default provider is ~:trigram~ — it captures lexical overlap (character trigram bloom filter → cosine similarity approximates Jaccard) and works immediately with zero configuration. Switch to ~:local~ or ~:openai~ when you have an embedding server; switch to ~:sha256~ for integrity-only deployments. + +**Why not SHA-256 by default?** SHA-256 is a cryptographic hash with the avalanche property — one-bit input differences produce entirely different outputs. "implement user login form" and "implement user login forn" (one character difference) have completely different SHA-256 values → cosine similarity near zero. This makes SHA-256 correct for integrity verification (Merkle tree) but useless for similarity-based retrieval. The trigram Jaccard approach captures lexical overlap: "authentication" and "authenticate" share trigrams "aut", "uth", "the", "hen", "ent", "nti", "tic", "ica", producing high cosine similarity (0.80). "authentication" and "banana" share zero trigrams → 0.0 similarity. + +This replaces the old ~system-embedding-gateway~ with the same logic but renamed to ~system-model-embedding~ to live alongside the other ~system-model-*~ skills. + +* Implementation + +** State +#+begin_src lisp +(in-package :passepartout) + +(defvar *embedding-provider* :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.") +#+end_src + +** Local backend (OpenAI-compatible) +#+begin_src lisp +(defun embedding-backend-local (text) + "Generate embeddings via a local OpenAI-compatible endpoint." + (let* ((url (or (uiop:getenv "LOCAL_BASE_URL") (format nil "http://~a" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434")))) + (model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text")) + (body (cl-json:encode-json-to-string + `((model . ,model) (input . ,text))))) + (handler-case + (let* ((response (dex:post (format nil "~a/api/embeddings" url) + :headers '(("Content-Type" . "application/json")) + :content body :connect-timeout 5 :read-timeout 30)) + (json (cl-json:decode-json-from-string response)) + (data (car (cdr (assoc :data json))))) + (or (cdr (assoc :embedding data)) + (list :error "No embedding in response"))) + (error (c) + (list :error (format nil "Embedding failed: ~a" c)))))) +#+end_src + +** OpenAI backend +#+begin_src lisp +(defun embedding-backend-openai (text) + "Generate embeddings via OpenAI compatible /v1/embeddings endpoint." + (let* ((api-key (uiop:getenv "OPENAI_API_KEY")) + (base-url (or (uiop:getenv "EMBEDDING_BASE_URL") "https://api.openai.com/v1")) + (model (or (uiop:getenv "EMBEDDING_MODEL") "text-embedding-3-small")) + (body (cl-json:encode-json-to-string + `((model . ,model) (input . ,text))))) + (handler-case + (let* ((response (dex:post (format nil "~a/embeddings" base-url) + :headers `(("Content-Type" . "application/json") + ("Authorization" . ,(format nil "Bearer ~a" api-key))) + :content body :connect-timeout 5 :read-timeout 30)) + (json (cl-json:decode-json-from-string response)) + (data (car (cdr (assoc :data json))))) + (or (cdr (assoc :embedding data)) + (list :error "No embedding in response"))) + (error (c) + (list :error (format nil "OpenAI Embedding failed: ~a" c)))))) +#+end_src + +** Trigram backend (v0.4.0) +#+begin_src lisp +(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)) +#+end_src + +** Object embedding and queuing +#+begin_src lisp +(defvar *embedding-backend* nil + "Explicit backend override (nil = use *embedding-provider*).") + +(defun embeddings-compute (text) + "Compute an embedding vector for text using the active backend." + (embed-object text)) + +(defun embed-object (text) + "Embed a single text string using the active backend." + (let* ((selected (or *embedding-backend* *embedding-provider* :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*) +#+end_src + +** Stale vector marking +#+begin_src lisp +(defun mark-vector-stale (id &optional content) + "Mark a memory object's vector as :pending and queue it for re-embedding. +When content is not supplied, reads from the object in *memory-store*." + (let* ((obj (gethash id *memory-store*)) + (text (or content (and obj (memory-object-content obj))))) + (when obj + (setf (memory-object-vector obj) :pending)) + (when text + (push (list :id id :text text) *embedding-queue*) + (log-message "EMBEDDING: Marked ~a vector stale, queued for re-embed" id)) + (or obj text))) +#+end_src + +** Skill Registration and Cron +#+begin_src lisp +(defskill :passepartout-system-model-embedding + :priority 70 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) + +;; Register periodic batch embedding via cron (when orchestrator available) +(when (fboundp 'orchestrator-register-cron) + (handler-case + (orchestrator-register-cron :embed-batch + "<2026-05-05 Tue +10m>" + 'embed-all-pending + :reflex) + (error (c) + (log-message "EMBEDDING: Cron registration failed: ~a" c)))) +#+end_src + +* Contract + +1. (embeddings-compute text): produces a vector (single-float array) for + any text string using the active backend (~*embedding-backend*~ or + ~*embedding-provider*~). +2. (embedding-backend-hashing text): zero-dependency fallback. Returns + an 8-element single-float vector deterministically from SHA-256. +3. (embed-all-pending): drains ~*embedding-queue*~, computes vectors for + all queued objects, and stores them in ~*memory-store*~ entries. +4. (mark-vector-stale id &optional content): sets ~:vector~ to ~:pending~ + and pushes object to ~*embedding-queue*~ for background re-embedding. +5. Cron: ~embed-all-pending~ is registered with the orchestrator to run + on ~:reflex~ tier every 10 minutes for background batch processing. + +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-embedding-tests + (:use :cl :passepartout) + (:export #:embedding-suite)) + +(in-package :passepartout-embedding-tests) + +(fiveam:def-suite embedding-suite :description "Embedding gateway verification") +(fiveam:in-suite embedding-suite) + +(fiveam:test test-embedding-backend-hashing + "Contract 2: hashing backend produces 8-element float vector." + (let ((vec (embedding-backend-hashing "hello world"))) + (fiveam:is (arrayp vec)) + (fiveam:is (= 8 (length vec))) + (fiveam:is (every #'numberp (coerce vec 'list))))) + +(fiveam:test test-embedding-backend-hashing-deterministic + "Contract 2: same input produces same vector." + (let ((v1 (embedding-backend-hashing "test")) + (v2 (embedding-backend-hashing "test"))) + (fiveam:is (equalp v1 v2)))) + +(fiveam:test test-embeddings-compute + "Contract 1: embeddings-compute returns a float vector." + (let ((vec (embeddings-compute "some text"))) + (fiveam:is (arrayp vec)) + (fiveam:is (> (length vec) 0)))) + +(fiveam:test test-embed-queue-and-drain + "Contract 3: embed-all-pending drains queue and stores vectors." + (let ((*embedding-queue* nil)) + (embed-queue-object '(:id "test-obj" :text "sample text")) + (fiveam:is (= 1 (length *embedding-queue*))) + (embed-all-pending) + (fiveam:is (null *embedding-queue*)))) + +(fiveam:test test-mark-vector-stale + "Contract 4: mark-vector-stale sets vector to :pending and queues for re-embed." + (let ((*embedding-queue* nil)) + ;; Create an object in memory with a vector + (let ((obj (make-memory-object :id "stale-test" :content "stale content" + :vector #(1.0 2.0 3.0)))) + (setf (gethash "stale-test" *memory-store*) obj) + (mark-vector-stale "stale-test") + (fiveam:is (eq :pending (memory-object-vector obj))) + (fiveam:is (= 1 (length *embedding-queue*))) + (let ((item (first *embedding-queue*))) + (fiveam:is (string= "stale-test" (getf item :id))) + (fiveam:is (string= "stale content" (getf item :text)))) + ;; Clean up + (remhash "stale-test" *memory-store*)))) +#+end_src diff --git a/org/embedding-native.org b/org/embedding-native.org new file mode 100644 index 0000000..003a21b --- /dev/null +++ b/org/embedding-native.org @@ -0,0 +1,361 @@ +#+TITLE: SKILL: Native Embedding Inference (org-skill-embedding-native.org) +#+AUTHOR: Agent +#+FILETAGS: :skill:system:embedding:cffi: +#+PROPERTY: header-args:lisp :tangle ../lisp/embedding-native.lisp + +* Architectural Intent + +=system-model-embedding-native= provides in-process embedding inference via CFFI binding to llama.cpp. Unlike =:local= (Ollama REST API) and =:openai= (paid API), =:native= runs the embedding model directly in the SBCL process — zero network calls, zero external servers. + +The bundled model is =nomic-embed-text-v1.5= (nomic-bert, 768-dim, 12 layers, Q4_K_M quantization, ~80MB) at =~/.local/share/passepartout/models/nomic-embed-text-v1.5.Q4_K_M.gguf=. It is a BERT-family encoder-only model — single forward pass, no autoregressive decoding. + +**Key architectural decisions**: +- C wrapper library (=/usr/local/lib/libllama_wrap.so=) bridges CFFI pointer params to llama.cpp's struct-by-value API (CFFI cannot pass/return structs by value) +- Struct sizes verified via C ~sizeof~ / ~offsetof~: =llama_model_params= (72B), =llama_context_params= (136B), =llama_batch= (56B) +- Model and context cached globally in =*native-model*= / =*native-context*= to avoid reloading +- BERT pooling: =llama_get_embeddings_seq= for sequence-level embedding (not =llama_get_embeddings_ith=) +- =sb-int:set-floating-point-modes= :traps nil required before any llama.cpp call (FPU state conflict) + +* Implementation + +** Package guard +#+begin_src lisp +(unless (find-package :passepartout) + (make-package :passepartout :use '(:cl))) + +(in-package :passepartout) +#+end_src + +** CFFI: Load C wrapper + llama libraries + +The C wrapper (=libllama_wrap.so=) bridges struct-by-value: all wrapper functions take pure pointers and dereference internally. + +#+begin_src lisp +(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) +#+end_src + +** CFFI: Struct definitions + +Sizes verified via C =sizeof= / =offsetof= at build time. + +#+begin_src lisp +(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)) +#+end_src + +** CFFI: llama.cpp API (current, non-deprecated) + +llama.cpp has undergone API changes. We target the current stable API: +- =llama_model_load_from_file= → C wrapper (=llama_wrap_model_load=) +- =llama_init_from_model= → C wrapper (=llama_wrap_new_context=) +- =llama_encode= → C wrapper (=llama_wrap_encode=) — takes struct-by-value batch +- =llama_batch_init/free= → C wrapper — returns/consumes struct-by-value +- =llama_backend_init= REQUIRED before any model load +- =llama_model_n_embd= (NOT deprecated =llama_n_embd=) +- =llama_model_get_vocab= + =llama_vocab_n_tokens= (NOT deprecated =llama_n_vocab= with model pointer) +- =llama_tokenize= now takes =vocab*= not =model*= +- =llama_get_embeddings_seq= for BERT pooled embeddings (=llama_get_embeddings_ith= for token embeddings) +- =llama_pooling_type= to query context pooling strategy + +#+begin_src lisp +;; 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)) +#+end_src + +** Global state + +#+begin_src lisp +(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.") +#+end_src + +** Model loading + +Loads the GGUF model file and creates an inference context. Caches globally — subsequent calls are no-ops. + +Key initialization: +- =sb-int:set-floating-point-modes= :traps nil — required or llama.cpp FPU ops SIGFPE +- =llama_backend_init= — must run before any model operation +- Model params: GPU off (=n-gpu-layers=0), no mmap (avoids double-free with SBCL's malloc) +- Context params: embeddings=1, 512-token context, 2 threads, =pooling_type= unset (let model decide) + +#+begin_src lisp +(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 'llama-mparams) + (mdp mp) + (setf (cffi:foreign-slot-value mp 'llama-mparams 'n-gpu-layers) 0) + (setf (cffi:foreign-slot-value mp '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 'llama-cparams) + (cdp cp) + (setf (cffi:foreign-slot-value cp 'llama-cparams 'n-ctx) 512) + (setf (cffi:foreign-slot-value cp 'llama-cparams 'n-batch) 512) + (setf (cffi:foreign-slot-value cp 'llama-cparams 'n-ubatch) 512) + (setf (cffi:foreign-slot-value cp 'llama-cparams 'n-seq-max) 1) + (setf (cffi:foreign-slot-value cp 'llama-cparams 'n-threads) 2) + (setf (cffi:foreign-slot-value cp '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*)) +#+end_src + +** Embedding inference + +Computes a 768-dim single-float vector for the given text via llama.cpp. + +Pipeline: +1. Load/cache model + context +2. Tokenize text via =llama_tokenize= (takes =vocab*= not =model*= since v0.4.1) +3. Initialize batch via C wrapper (=llama_batch_init= returns struct-by-value) +4. Fill batch: set =tokens=, =pos=, =n_seq_id=, =seq_id[0]=, =logits= for each position +5. CRITICAL: set =batch.n_tokens= explicitly — =llama_batch_init= initializes it to 0 +6. Encode via C wrapper (=llama_encode= takes struct-by-value batch) +7. Extract pooled embedding via =llama_get_embeddings_seq= (BERT CLS pooling) + — falls back to =llama_get_embeddings_ith= if =pooling_type == NONE= +8. Free batch memory via wrapper (=llama_batch_free= takes struct-by-value) + +NOTE: we write =seq_id= values directly into the arrays allocated by +=llama_batch_init= (not foreign-alloc'd separately) to avoid double-free. + +#+begin_src lisp +(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 'llama-batch) + (wrap-batch-init batch n-tok 0 1) + (setf (cffi:foreign-slot-value batch 'llama-batch 'n-tokens) n-tok) + (dotimes (i n-tok) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch 'llama-batch 'token) :int32 i) + (cffi:mem-aref tokens :int32 i)) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch 'llama-batch 'pos) :int32 i) i) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch 'llama-batch 'n-seq-id) :int32 i) 1) + (setf (cffi:mem-aref (cffi:mem-aref (cffi:foreign-slot-value batch 'llama-batch 'seq-id) :pointer i) :int32 0) 0) + (setf (cffi:mem-aref (cffi:foreign-slot-value batch '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)))) +#+end_src + +** Cleanup and unload + +#+begin_src lisp +(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)) +#+end_src + +** Cosine similarity helper + +Used in tests and embedding comparisons. + +#+begin_src lisp +(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)))))) +#+end_src + +* Test Suite + +#+begin_src lisp +(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))))) +#+end_src + +* C Wrapper Source + +The C wrapper bridges CFFI's pointer-only interface to llama.cpp's struct-by-value API. +Compile with: =gcc -shared -fPIC -I/tmp/llama.cpp/include -o libllama_wrap.so llama_wrap.c -L/usr/local/lib -lllama= + +#+begin_src c :tangle ../scripts/llama_wrap.c +// C wrapper for llama.cpp — bridges CFFI pointer params to struct-by-value +// Compile: gcc -shared -fPIC -I/tmp/llama.cpp/include -o libllama_wrap.so llama_wrap.c -L/usr/local/lib -lllama + +#include + +struct llama_model * llama_wrap_model_load(const char * path, struct llama_model_params * params) { + return llama_model_load_from_file(path, *params); +} + +struct llama_context * llama_wrap_new_context(struct llama_model * model, struct llama_context_params * params) { + return llama_init_from_model(model, *params); +} + +int32_t llama_wrap_encode(struct llama_context * ctx, struct llama_batch * batch) { + return llama_encode(ctx, *batch); +} + +void llama_wrap_batch_init(struct llama_batch * batch, int32_t n_tokens, int32_t embd, int32_t n_seq_max) { + *batch = llama_batch_init(n_tokens, embd, n_seq_max); +} + +void llama_wrap_batch_free(struct llama_batch * batch) { + llama_batch_free(*batch); +} +#+end_src diff --git a/org/gateway-messaging.org b/org/gateway-messaging.org index 3a8f285..c4c75d1 100644 --- a/org/gateway-messaging.org +++ b/org/gateway-messaging.org @@ -41,202 +41,9 @@ This replaces the old ~gateway-manager~ skill. The Telegram/Signal platform code "Maps platform name to plist (:poll-fn :send-fn :default-interval)") #+end_src -** Telegram -#+begin_src lisp -(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)))))) -#+end_src -** Signal -#+begin_src lisp -(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)))))) -#+end_src - -** Discord -Discord Bot API: REST for sending, Gateway WebSocket for receiving real-time messages via MESSAGE_CREATE events. Maps Discord mentions to :user-input signals. HITL commands work identically to Telegram. -#+begin_src lisp -(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)))))) -#+end_src - -** Slack -Slack Events API + Web API. Subscribes to message.im events, sends via chat.postMessage. Reuses the SLACK_TOKEN config key from setup wizard. -#+begin_src lisp -(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))))))) -#+end_src ** Registry initialization #+begin_src lisp diff --git a/org/neuro-explorer.org b/org/neuro-explorer.org new file mode 100644 index 0000000..d61fd76 --- /dev/null +++ b/org/neuro-explorer.org @@ -0,0 +1,155 @@ +#+TITLE: SKILL: Model Explorer (org-skill-model-explorer.org) +#+AUTHOR: Agent +#+FILETAGS: :skill:model:explorer:discovery: +#+PROPERTY: header-args:lisp :tangle ../lisp/neuro-explorer.lisp + +* Architectural Intent + +~system-model-explorer~ answers two questions the config screen needs: "What models does my provider offer?" and "Which one should I use for this task?" + +It opens a thin pipe to OpenRouter's /api/v1/models endpoint (no API key needed for the model list), parses the JSON into a uniform set of plists, and caches the result. The TUI's model dropdowns and recommendation cards all read from this cache. + +Recommended models are curated per task slot — code generation needs different capabilities than casual chat or background summarization. The recommendations are not hardcoded provider hooks; they're hand-picked from the OpenRouter free tier as a sensible default. Users can override via the TUI config screen, which replaces the picked model IDs into their cascade. + +** Contract + +1. (model-explorer-recommend slot): returns a list of plists with + ~:id~ and ~:name~ for the given task slot (~:code~, ~:chat~, + ~:plan~, ~:background~). Unknown slots return a fallback list. +2. (model-explorer-fetch provider): fetches the model list from the + provider's API and caches it. Returns nil on failure. + +* Implementation + +** Cache +#+begin_src lisp +(in-package :passepartout) + +(defvar *model-cache* (make-hash-table :test 'equal) + "Cache: provider keyword -> (timestamp . model-list)") + +(defvar *model-cache-ttl* 300 + "Cache TTL in seconds (default 5 min)") +#+end_src + +** OpenRouter fetch +#+begin_src lisp +(defun model-explorer-fetch-openrouter () + "Query OpenRouter /api/v1/models and return parsed model list." + (handler-case + (let* ((raw (dex:get "https://openrouter.ai/api/v1/models" :connect-timeout 10 :read-timeout 20)) + (json (cl-json:decode-json-from-string raw)) + (data (cdr (assoc :data json)))) + (mapcar (lambda (m) + (let ((pricing (cdr (assoc :pricing m)))) + (list :id (cdr (assoc :id m)) + :name (cdr (assoc :name m)) + :context (cdr (assoc :context_length m)) + :free (and pricing + (string= "0" (cdr (assoc :prompt pricing))) + (string= "0" (cdr (assoc :completion pricing))))))) + data)) + (error (c) + (log-message "MODEL-EXPLORER: OpenRouter API error: ~a" c) + nil))) +#+end_src + +** Generic fetch with cache +#+begin_src lisp +(defun model-explorer-fetch (provider) + "Fetch available models for PROVIDER. Returns list of (:id :name :context :free) plists." + (let ((cached (gethash provider *model-cache*))) + (when (and cached (< (- (get-universal-time) (car cached)) *model-cache-ttl*)) + (return-from model-explorer-fetch (cdr cached)))) + (let ((models (case provider + (:openrouter (model-explorer-fetch-openrouter)) + (t nil)))) + (when models + (setf (gethash provider *model-cache*) + (cons (get-universal-time) models))) + models)) +#+end_src + +** List-free convenience +#+begin_src lisp +(defun model-explorer-list-free () + "Return all free models from cache or fetch." + (remove-if-not (lambda (m) (getf m :free)) (model-explorer-fetch :openrouter))) +#+end_src + +** Curated recommendations per slot +#+begin_src lisp +(defun model-explorer-recommend (slot) + "Return recommended models for SLOT (:code, :chat, :plan, :background)." + (case slot + (:code + '((:id "qwen/qwen3-coder:free" :name "Qwen3 Coder 480B" :context 262000 :free t :note "Top-tier code MoE, 35B active") + (:id "poolside/laguna-m.1:free" :name "Laguna M.1" :context 131072 :free t :note "Flagship coding agent") + (:id "openai/gpt-oss-120b:free" :name "gpt-oss-120b" :context 131072 :free t :note "117B MoE open-weight coding"))) + (:plan + '((:id "openrouter/owl-alpha" :name "Owl Alpha" :context 1048756 :free t :note "Agentic, tool use, reasoning") + (:id "nousresearch/hermes-3-llama-3.1-405b:free" :name "Hermes 3 405B" :context 131072 :free t :note "405B generalist, strong planning") + (:id "minimax/minimax-m2.5:free" :name "MiniMax M2.5" :context 196608 :free t :note "SOTA productivity, long context"))) + (:chat + '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Strong multilingual generalist") + (:id "google/gemma-4-31b-it:free" :name "Gemma 4 31B" :context 262144 :free t :note "Dense 31B, thinking mode, long context") + (:id "mistralai/mistral-nemo:free" :name "Mistral Nemo" :context 32768 :free t :note "Fast, good for casual conversation"))) + (:background + '((:id "meta-llama/llama-3.2-3b-instruct:free" :name "Llama 3.2 3B" :context 131072 :free t :note "Small, fast, efficient") + (:id "liquid/lfm-2.5-1.2b-instruct:free" :name "LFM 2.5 1.2B" :context 32768 :free t :note "Ultra-compact, edge-ready"))) + (t '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Safe fallback"))))) +#+end_src + +** Slot descriptions (for TUI config display) +;; REPL-verified: 2026-05-04 +#+begin_src lisp +(defvar *slot-descriptions* + '((:code . "Code generation, refactoring, debugging. Needs strong reasoning and large context.\nRecommend: Qwen3 Coder (free, 35B active) or Laguna M.1 (coding agent).") + (:chat . "Casual conversation, Q&A, creative writing. Prefer balanced quality, low latency.\nRecommend: Llama 3.3 70B (strong generalist) or Gemma 4 31B (thinking mode).") + (:plan . "Strategic planning, architecture design, complex multi-step reasoning.\nRecommend: Owl Alpha (free, tool use, 1M ctx) or Hermes 3 405B (strongest free reasoning).") + (:background . "Heartbeat summaries, delegation responses, tool output filtering. Must be small + fast.\nRecommend: Llama 3.2 3B (131K ctx, fast) or LFM 2.5 1.2B (edge-ready)."))) +#+end_src + +* Tests + +#+begin_src lisp +;; REPL-verified: 2026-05-04 +(eval-when (:compile-toplevel :load-toplevel :execute) + (ignore-errors (ql:quickload :fiveam :silent t))) + +(defpackage :passepartout-system-model-explorer-tests + (:use :cl :passepartout) + (:export #:model-explorer-suite)) + +(in-package :passepartout-system-model-explorer-tests) + +(fiveam:def-suite model-explorer-suite :description "Tests for the model explorer skill") + +(fiveam:in-suite model-explorer-suite) + +(fiveam:test model-explorer-recommend-slots + "Contract 1: recommend returns models for all standard slots." + (dolist (slot '(:code :chat :plan :background)) + (let ((recs (passepartout::model-explorer-recommend slot))) + (fiveam:is (listp recs)) + (fiveam:is (>= (length recs) 1))))) + +(fiveam:test model-explorer-recommend-format + "Contract 1: each recommendation has :id and :name." + (dolist (rec (passepartout::model-explorer-recommend :chat)) + (fiveam:is (getf rec :id)) + (fiveam:is (getf rec :name)))) + +(fiveam:test model-explorer-recommend-unknown-slot + "Contract 1: unknown slot returns fallback list." + (let ((recs (passepartout::model-explorer-recommend :unknown))) + (fiveam:is (listp recs)) + (fiveam:is (>= (length recs) 1)))) + +(fiveam:test model-explorer-fetch-openrouter-count + "Contract 2: OpenRouter API returns at least 300 models." + (let ((models (passepartout::model-explorer-fetch :openrouter))) + (if models + (fiveam:is (>= (length models) 300)) + (fiveam:skip "API unreachable")))) +#+end_src diff --git a/org/neuro-provider.org b/org/neuro-provider.org new file mode 100644 index 0000000..775e012 --- /dev/null +++ b/org/neuro-provider.org @@ -0,0 +1,234 @@ +#+TITLE: SKILL: Unified LLM Backend (org-skill-unified-llm-backend.org) +#+AUTHOR: Agent +#+FILETAGS: :skill:model:provider:llm: +#+PROPERTY: header-args:lisp :tangle ../lisp/neuro-provider.lisp + +* Architectural Intent + +~system-model-provider~ is the universal LLM client. It speaks the OpenAI-compatible ~/v1/chat/completions~ protocol, which covers every modern provider — OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM, plus any local engine (Ollama, vLLM, LM Studio, llama.cpp) when running behind an OpenAI-compatible adapter. + +One function, eight (and counting) providers. The same JSON payload, the same response format, the same error handling. Adding a new provider is a one-line config entry: a keyword, a base URL, an API key env var name, and a default model. + +Providers register themselves at boot. No API key? That provider doesn't register. No local URL set? The local entry stays dormant. Only the providers you actually configure appear in ~*probabilistic-backends*~ at runtime. The old code assumed Ollama was always available; this code requires an env var like everything else. + +=*provider-cascade*= defaults to cloud-only (all providers except ~:local~ and ~:ollama~). If you want a local fallback, set ~LOCAL_BASE_URL~ in your env and add ~:local~ to the ~PROVIDER_CASCADE~ list. + +** Contract + +1. (provider-config provider): returns the configuration plist for a + provider keyword, or nil if unregistered. +2. (provider-available-p provider): returns T if the provider's API key + or base URL is configured. +3. (provider-openai-request prompt system-prompt &key model provider): + executes an OpenAI-compatible /v1/chat/completions request. Returns + ~(:status :success :content ...)~ or ~(:status :error :message ...)~. +4. (provider-openai-request prompt system-prompt &key model provider tools): + when ~:tools~ is provided (a list of plist tool definitions), the request + body includes ~"tools"~ and ~"tool_choice": "auto"~ fields. Parses + ~tool_calls~ from the response: extracts ~function.name~ and + ~function.arguments~ (decoded from JSON string to alist). Returns + ~(:status :success :tool-calls ((:name :arguments )))~ + when the LLM returns a tool call, or the existing ~:content~ path otherwise. +4. (provider-cascade-initialize): reads ~PROVIDER_CASCADE~ from env and + sets ~*provider-cascade*~. + +* Implementation + +** Provider registry +#+begin_src lisp +(in-package :passepartout) + +(defparameter *provider-configs* + '((:local . (:base-url nil :key-env nil :url-env "LOCAL_BASE_URL" :default-model "llama3")) + (:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto")) + (:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini")) + (:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022")) + (:groq . (:base-url "https://api.groq.com/openai/v1" :key-env "GROQ_API_KEY" :default-model "llama-3.1-70b-versatile")) + (:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash")) + (:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat")) + (:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct")))) +#+end_src + +** Provider config lookup +#+begin_src lisp +(defun provider-config (provider) + "Returns the configuration plist for a provider keyword." + (cdr (assoc provider *provider-configs*))) +#+end_src + +** Availability check +#+begin_src lisp +(defun provider-available-p (provider) + "Checks if a provider is configured. Checks API key or URL env vars." + (let* ((config (provider-config provider)) + (key-env (getf config :key-env)) + (url-env (getf config :url-env)) + (base-url (getf config :base-url))) + (cond (key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0)))) + (url-env (let ((url (uiop:getenv url-env))) (and url (> (length url) 0)))) + (base-url t)))) +#+end_src + +** Unified request execution +#+begin_src lisp +(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter) 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 10 timeout) + :read-timeout (max 10 (- timeout 5)))) + (json (cl-json:decode-json-from-string response)) + (choices (cdr (assoc :choices json))) + (first-choice (car choices)) + (message (cdr (assoc :message first-choice))) + (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)))))) +#+end_src + +** Register all available providers +#+begin_src lisp +(defun provider-register-all () + "Scans environment variables and registers all available LLM backends." + (dolist (entry *provider-configs*) + (let ((provider (car entry))) + (when (provider-available-p provider) + (log-message "LLM BACKEND: Registering provider ~a" provider) + (register-probabilistic-backend provider + (lambda (prompt system-prompt &key model tools) + (provider-openai-request prompt system-prompt :model model :provider provider :tools tools))))))) +#+end_src + +** Initialize cascade +#+begin_src lisp +(defun provider-cascade-initialize () + "Reads PROVIDER_CASCADE from env and sets *provider-cascade*." + (let ((cascade-str (uiop:getenv "PROVIDER_CASCADE"))) + (if cascade-str + (setf *provider-cascade* + (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword)) + (uiop:split-string cascade-str :separator '(#\,)))) + (setf *provider-cascade* (mapcar #'car (remove-if (lambda (e) + (member (car e) '(:local))) + *provider-configs*)))))) +#+end_src + +** Provider connection test (for TUI config) +;; REPL-verified: 2026-05-04 +#+begin_src lisp +(defun test-provider-connection (provider &optional api-key) + "Test a provider API key by hitting its models endpoint. +Returns (:ok) on success, (:fail reason) on failure. +If API-KEY is nil, reads from environment." + (let* ((config (provider-config provider)) + (base-url (getf config :base-url)) + (key-env (getf config :key-env)) + (url-env (getf config :url-env)) + (key (or api-key (when key-env (uiop:getenv key-env))))) + (handler-case + (let ((url (if url-env + (let ((host (or (uiop:getenv url-env) ""))) + (format nil "http://~a/api/tags" host)) + (format nil "~a/models" (or base-url ""))))) + (if key-env + (progn (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" key))) + :connect-timeout 5 :read-timeout 10) + '(:ok)) + (if url-env + (progn (dex:get url :connect-timeout 5 :read-timeout 10) '(:ok)) + '(:fail "No URL source for this provider")))) + (error (c) `(:fail ,(format nil "~a" c)))))) +#+end_src + +** Boot registration +#+begin_src lisp +(provider-register-all) +(provider-cascade-initialize) +#+end_src + +** Skill registration +#+begin_src lisp +(defskill :passepartout-system-model-provider + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) +#+end_src + +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-llm-gateway-tests + (:use :cl :passepartout) + (:export #:llm-gateway-suite)) + +(in-package :passepartout-llm-gateway-tests) + +(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend") +(fiveam:in-suite llm-gateway-suite) + +(fiveam:test test-provider-rejects-bad-keyword + "Contract 3: provider-config returns nil for unregistered provider." + (let ((config (provider-config :not-a-real-provider))) + (fiveam:is (null config)))) + +(fiveam:test test-provider-config-registered + "Contract 1: provider-config returns configuration plist for registered provider." + (let ((config (provider-config :openrouter))) + (fiveam:is (listp config)) + (fiveam:is (getf config :base-url)))) + +(fiveam:test test-provider-accepts-tools-parameter + "Contract 4: provider-openai-request accepts :tools parameter without error." + (let ((result (provider-openai-request "test" "system" :tools (list)))) + (fiveam:is (member (getf result :status) '(:success :error))))) +#+end_src diff --git a/org/neuro-router.org b/org/neuro-router.org new file mode 100644 index 0000000..befc30c --- /dev/null +++ b/org/neuro-router.org @@ -0,0 +1,223 @@ +#+TITLE: SKILL: Model Router (org-skill-model-router.org) +#+AUTHOR: Agent +#+FILETAGS: :system:model:routing: +#+PROPERTY: header-args:lisp :tangle ../lisp/neuro-router.lisp + +* Overview: Quadrant-Based Model Routing + +The Model Router implements the four-quadrant cognitive architecture for +LLM model selection. Each signal is routed through a pipeline of three +filters — privacy, quadrant, and complexity — before a model is chosen. + +The routing pipeline for every probabilistic signal: + + all backends → privacy filter → quadrant/classifier → per-slot cascade → model + +- **Privacy filter** strips cloud backends when content carries ~@personal~ tags. +- **Quadrant** determines if the signal is foreground or background. +- **Complexity classifier** assigns foreground signals to one of three slots: + ~:code~, ~:plan~, or ~:chat~. +- **Per-slot cascade** selects a backend and model for the slot, with fallback + ordering defined in each cascade list. + +The model selector function is registered into the core ~*model-selector*~ hook +at load time. The core iterates providers, calling the selector for each one. + +* Implementation + +** Package Context + +#+begin_src lisp +(in-package :passepartout) +#+end_src + +** Configuration: Per-Slot Cascades + +Four env-configurable cascade variables, one per slot. Each cascade is a list +of ~(provider-keyword . "model-name")~ pairs. The first match for the current +backend is used. + +Example: + MODEL_CASCADE_CODE='((:ollama . "deepseek-coder:6.7b") (:openrouter . "claude-sonnet"))' + +*** *model-cascade-code* + +The cascade for ~:code~ tasks (code generation, refactoring, bug fixing). +Format: ~((:ollama . "model-name") ...)~. Configured via ~MODEL_CASCADE_CODE~. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defvar *model-cascade-code* nil + "Cascade for :code tasks: ((:ollama . \"model\") ...)") +#+end_src + +*** *model-cascade-plan* + +Cascade for planning and architecture tasks. Configured via ~MODEL_CASCADE_PLAN~. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defvar *model-cascade-plan* nil + "Cascade for :plan tasks.") +#+end_src + +*** *model-cascade-chat* + +Cascade for general conversation and simple Q&A. Configured via ~MODEL_CASCADE_CHAT~. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defvar *model-cascade-chat* nil + "Cascade for :chat tasks.") +#+end_src + +*** *model-cascade-background* + +Cascade for background tasks (heartbeat scraping, delegation processing). +Configured via ~MODEL_CASCADE_BACKGROUND~. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defvar *model-cascade-background* nil + "Cascade for background tasks (heartbeat, delegation).") +#+end_src + +*** *local-backends* + +List of backend keywords considered local for privacy routing. Content tagged +with ~@personal~ will only be sent to these backends. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defvar *local-backends* '(:ollama :llama-cpp) + "Backend keywords considered local (privacy-safe).") +#+end_src + +** Complexity Classifier + +Keyword-based heuristic that assigns signal text to a complexity slot. +Pluggable — set ~*complexity-classifier*~ to override. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun model-classify-complexity (text) + "Classify TEXT into :code, :plan, or :chat." + (let ((lower (string-downcase text))) + (cond + ((or (search "defun" lower) (search "defmacro" lower) + (search "write" lower) (search "refactor" lower) + (search "fix " lower) (search "implement" lower) + (search "code" lower) + (search "#+begin_src" lower)) + :code) + ((or (search "plan" lower) (search "roadmap" lower) + (search "strategy" lower) (search "design" lower) + (search "architecture" lower)) + :plan) + (t :chat)))) +#+end_src + +** Cascade Lookup + +The core iterates each backend in ~*provider-cascade*~ and calls the model +selector for each one. This function matches the current backend against the +per-slot cascade list to find the appropriate model. Returns the first +~:code~ ~(provider . model)~ entry whose provider matches, or ~nil~ if +the backend has no entry in that slot's cascade (the core will skip to +the next provider). + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun model-cascade-find (cascade backend) + "Find first (PROVIDER . MODEL) in CASCADE matching BACKEND." + (assoc backend cascade + :test (lambda (a b) (string-equal (string a) (string b))))) +#+end_src + +** Model Selector + +The main routing function. Registered into ~*model-selector*~ at init time. +Called per-backend by ~backend-cascade-call~. Returns a model name string, +or ~:skip~ if the backend should not be tried (e.g., privacy filter). + +Filter order: privacy → quadrant → complexity → cascade. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun model-select (backend context) + "Select model for BACKEND given CONTEXT signal. +Returns model name or :skip." + (let* ((payload (getf context :payload)) + (text (or (getf payload :text) "")) + (sensor (getf payload :sensor)) + (has-personal (and (boundp '*dispatcher-privacy-tags*) + (some (lambda (tag) (search tag text)) + (symbol-value '*dispatcher-privacy-tags*)))) + (is-local (member backend *local-backends*))) + ;; Privacy: skip cloud backends for personal content + (when (and has-personal (not is-local)) + (log-message "MODEL-ROUTER: Skipping ~a (personal content)" backend) + (return-from model-select :skip)) + ;; Quadrant: background tasks use background cascade + (if (member sensor '(:heartbeat :delegation :tool-output :loop-error)) + (let ((entry (car (or *model-cascade-background* + '((:ollama . "phi-2")))))) + (cdr entry)) + ;; Foreground: classify complexity, use slot cascade + (let* ((slot (model-classify-complexity text)) + (cascade (case slot + (:code *model-cascade-code*) + (:plan *model-cascade-plan*) + (t *model-cascade-chat*))) + (entry (model-cascade-find + (or cascade '((:ollama . "qwen2.5:14b"))) backend))) + (if entry (cdr entry) nil))))) +#+end_src + +** Initialization + +Reads cascade configuration from environment variables and registers +~model-select~ into the core ~*model-selector*~ hook. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun model-router-init () + "Read env vars and wire model-select into *model-selector*." + (flet ((parse-cascade (str) + (when (and str (> (length str) 0)) + (let ((*read-eval* nil)) + (read-from-string str))))) + (setf *model-cascade-code* (parse-cascade (uiop:getenv "MODEL_CASCADE_CODE")) + *model-cascade-plan* (parse-cascade (uiop:getenv "MODEL_CASCADE_PLAN")) + *model-cascade-chat* (parse-cascade (uiop:getenv "MODEL_CASCADE_CHAT")) + *model-cascade-background* (parse-cascade (uiop:getenv "MODEL_CASCADE_BACKGROUND")) + *local-backends* (let ((env (uiop:getenv "LOCAL_BACKENDS"))) + (if env + (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword)) + (uiop:split-string env :separator '(#\,))) + '(:ollama :llama-cpp))))) + (setf *model-selector* #'model-select) + (log-message "MODEL-ROUTER: Initialized, selector=~a" *model-selector*)) +#+end_src + +** Skill Registration + +The model router is an observer skill — it has no trigger and no +deterministic gate. All work happens at load time via ~model-router-init~, +which reads env vars and registers into the core ~*model-selector*~ hook. +The ~defskill~ call exists only to register metadata (priority, name) for +telemetry and lifecycle management. + +#+begin_src lisp +(defskill :passepartout-model-router + :priority 250 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) +#+end_src + +** Auto-Init + +#+begin_src lisp +(model-router-init) +#+end_src + + diff --git a/org/symbolic-archivist.org b/org/symbolic-archivist.org new file mode 100644 index 0000000..6df0cef --- /dev/null +++ b/org/symbolic-archivist.org @@ -0,0 +1,381 @@ +#+TITLE: SKILL: Archivist (org-skill-archivist.org) +#+AUTHOR: Agent +#+FILETAGS: :skill:archivist:scribe:gardener: +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-archivist.lisp + +* Overview + +The *Archivist* combines the former Scribe and Gardener skills into a unified +maintenance subsystem. It runs as a background skill triggered by heartbeat +events, performing two core functions: + +- Scribe: Distills daily chronological logs into structured atomic notes with + backlinks, maintaining the Zettelkasten knowledge base. +- Gardener: Scans the Memex for structural issues — broken =[[file:...]]= links + and orphaned =memory-object= entries — flagging them for human review. + +** Contract + +1. (archivist-extract-headlines content): parses Org content into a + list of headline structures, each with ~:title~, ~:body~, ~:tags~. +2. (archivist-headline-to-filename title): sanitizes a headline title + into a valid filename — lowercased, special chars replaced. +3. (archivist-create-note headline notes-dir source): writes a + Zettelkasten note to disk with frontmatter and backlinks. +4. (archivist-scribe-distill): heartbeat-driven — reads recent log + entries from ~*history-store*~ and creates structured notes. +5. (archivist-gardener-scan): heartbeat-driven — scans for broken + file links and orphaned memory objects. + +* Implementation + +** Package Context +#+begin_src lisp +(in-package :passepartout) +#+end_src + +** Archivist State + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(in-package :passepartout) + +(defvar *archivist-last-scribe* 0 + "Universal time of the last Scribe distillation run.") + +#+end_src +** *archivist-last-gardener* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *archivist-last-gardener* 0 + "Universal time of the last Gardener scan run.") + +#+end_src +** *archivist-gardener-interval* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *archivist-gardener-interval* 86400 + "Seconds between Gardener scans. Default: 24 hours.") +#+end_src +#+end_src + +** Scribe: Knowledge Distillation + +Reads daily log files from the Memex ~daily/= directory, extracts headlines +and conceptual content, and creates atomic notes in ~notes/= with source +backlinks. Tracks processed state via timestamp to avoid re-processing. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-scribe-distill () + "Distills daily log entries into atomic notes. Reads the Memex daily/ +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)) + +#+end_src +** archivist-extract-headlines +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-extract-headlines (content) + "Extracts first-level headlines and their content from Org text. +Returns a list of plists: (:title :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))) + +#+end_src +** archivist-headline-to-filename +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-headline-to-filename (title) + "Converts a headline title to a valid atomic note filename. +Replaces spaces and special chars with underscores, downcases." + (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))) + +#+end_src +** archivist-create-note +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-create-note (headline notes-dir source-filepath) + "Creates an atomic note from a headline plist in the notes/ directory. +Headline is a plist (:title :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)))) +#+end_src +#+end_src + +** Gardener: Structural Maintenance + +Scans the Memex for broken =[[file:...]]= links and orphaned =memory-object= +entries. Flags issues with =:GARDENER:= tags for human review. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-gardener-scan () + "Scans the Memex for broken file links and orphaned memory objects. +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))) + +#+end_src +** archivist-find-org-files +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-find-org-files (memex-dir) + "Recursively finds all .org files under memex-dir, up to 3 levels deep." + (let ((files nil)) + (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)) + +#+end_src +** archivist-extract-file-links +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-extract-file-links (content) + "Extracts all =[[file:...]]= link targets from Org content. +Returns a list of link target strings." + (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)) +#+end_src +#+end_src + +** Archivist Runner + +Triggered by heartbeat events, runs Scribe and Gardener on alternating schedules. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun archivist-run (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) +#+end_src + +** Skill Registration + +#+begin_src lisp +(defskill :passepartout-system-archivist + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic #'archivist-run) +#+end_src + +* Test Suite + +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-system-archivist-tests + (:use :cl :passepartout) + (:export #:archivist-suite)) + +(in-package :passepartout-system-archivist-tests) + +(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill") +(fiveam:in-suite archivist-suite) + +(fiveam:test test-extract-headlines + "Contract 1: archivist-extract-headlines parses Org content." + (let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline")) + (headlines (archivist-extract-headlines content))) + (fiveam:is (listp headlines)) + (fiveam:is (>= (length headlines) 1)))) + +(fiveam:test test-headline-to-filename + "Contract 2: archivist-headline-to-filename sanitizes titles." + (let ((filename (archivist-headline-to-filename "My Project: Overview"))) + (fiveam:is (search "my_project_overview" filename :test #'char-equal)) + (fiveam:is (not (search ":" filename))))) + +(fiveam:test test-archivist-create-note + "Contract 3: archivist-create-note writes a Zettelkasten note to disk." + (let* ((tmp-dir "/tmp/passepartout-archivist-test/") + (headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic")))) + (uiop:ensure-all-directories-exist (list tmp-dir)) + (unwind-protect + (progn + (fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org")) + "Expected note creation to return T") + (fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir)) + "Expected file test_note.org to exist")) + (uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t)))) +#+end_src \ No newline at end of file diff --git a/org/symbolic-awareness.org b/org/symbolic-awareness.org new file mode 100644 index 0000000..daf9413 --- /dev/null +++ b/org/symbolic-awareness.org @@ -0,0 +1,383 @@ +#+TITLE: Symbolic Awareness (symbolic-awareness.lisp) +#+AUTHOR: Agent +#+FILETAGS: :symbolic:awareness:skill: +#+STARTUP: content +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-awareness.lisp + +* Overview: Architectural Intent + +The Context API implements the Foveal-Peripheral awareness model. When the agent thinks, it doesn't dump everything it knows into the LLM's context window — that would saturate the token budget immediately. Instead, it builds a skeletal outline of the entire Memex and only shows full detail for the current focus. + +This mirrors human attention: you are aware of your entire apartment (peripheral vision), but you only see the book in front of you in detail (foveal vision). + +** The Foveal-Peripheral Model + +Three factors determine how much detail an object gets: + +1. **Depth** — objects within 2 levels of the root get full outline (title + ID). Deeper objects are summarized or omitted. +2. **Foveal focus** — the object the user is currently interacting with gets full content rendered. +3. **Semantic similarity** — objects whose vector embedding is similar to the current foveal focus get promoted from peripheral to foveal detail. + +** Why Not Just Dump Everything? + +A naive implementation that serializes every ~org-object~ to text would produce hundreds of thousands of tokens for a typical knowledge base. The LLM would spend its attention budget on noise, not signal. The Foveal-Peripheral model preserves the signal (the current task and related information) while reducing noise (everything else). + +The semantic threshold is configurable via ~CONTEXT_SEMANTIC_THRESHOLD~ env var (default 0.75). Lower values include more peripherally related content; higher values restrict to tightly related content. + +** Semantic Retrieval Activation (v0.4.0) + +In v0.3.0, the infrastructure for semantic retrieval was in place — the cosine similarity calculation, the semantic threshold check, and the embedding pipeline — but ~:foveal-vector~ was never passed to ~context-object-render~. It was always ~nil~, so ~(if (and foveal-vector obj-vector ...) ...)~ always took the ~0.0~ branch. Every peripheral node had similarity zero regardless of content overlap. + +The fix is a one-line wiring: ~context-awareness-assemble~ now extracts the foveal node's embedding vector via ~(memory-object-vector (memory-object-get foveal-id))~ and passes it as the ~:foveal-vector~ keyword argument to ~context-object-render~. This activates the entire semantic retrieval path — nodes with high cosine similarity to the foveal node are promoted to full-content rendering. + +The effectiveness of this depends on the embedding backend. The default ~:trigram~ backend (v0.4.0 replacement for ~:hashing~/SHA-256) captures lexical overlap: if two nodes share enough character trigrams, their cosine similarity exceeds the threshold and the peripheral node is promoted to foveal detail. This gives the context model genuine semantic boosting with zero LLM tokens and zero external dependencies. + +** Contract + +1. (context-awareness-assemble &optional signal): produces a skeletal + outline of current Memory for the LLM. If ~:foveal-focus~ is set, + the foveal node gets inline rendering; peripheral nodes get title-only. + Privacy-filtered objects are excluded. +2. (context-assemble-global-awareness): zero-arg wrapper — calls + ~context-awareness-assemble~ without foveal focus. + +* Implementation + +** Package Context +#+begin_src lisp +(in-package :passepartout) +#+end_src + +** Memory Query (context-query) + +Filters the Memory store by tag, TODO state, or object type. This is the primary retrieval function used by skills to find relevant information. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-query (&key tag todo-state type 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)) +#+end_src + +** Active Projects (context-active-projects) + +Returns headlines tagged as ~project~ that are not yet DONE. Used by the global awareness function to build the task overview. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-active-projects () + "Returns headlines tagged as 'project' that are not yet marked DONE." + (remove-if (lambda (obj) (equal (getf (memory-object-attributes obj) :TODO-STATE) "DONE")) + (context-query :tag "project" :type :HEADLINE))) +#+end_src + +** Completed Tasks (context-recent-tasks) + +Retrieves recently finished tasks from the store. Used by the Scribe and Gardener for journal summarization. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-recent-tasks () + "Retrieves recently finished tasks from the store." + (context-query :todo-state "DONE" :type :HEADLINE)) +#+end_src + +** Capability Discovery (context-skill-list) + +Provides a sorted overview of currently loaded system capabilities. Each entry includes the skill name, priority, and dependencies. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-skill-list () + "Provides a sorted overview of currently loaded system capabilities." + (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))))) +#+end_src + +** Skill Source Inspection (context-skill-source) + +Reads the raw literate source of a specific skill for inspection. Used when the agent needs to understand or modify its own code. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-skill-source (skill-name) + "Reads the raw literate source of a specific skill for inspection." + (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))) +#+end_src + +** Subtree Skill Source (context-skill-subtree) + +Returns a specific headline subtree from a skill's Org file. Delegates to +=org-subtree-extract= in the =programming-org= skill for actual parsing. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-skill-subtree (skill-name heading-name) + "Reads a specific headline subtree from a skill's Org source file. +Returns the content under HEADING-NAME (including children) as a string, +or nil if the heading is not found." + (let ((full-source (context-skill-source skill-name))) + (unless full-source (return-from context-skill-subtree nil)) + (if (fboundp 'org-subtree-extract) + (org-subtree-extract full-source heading-name) + ;; Fallback: no org-subtree-extract available, return full source + full-source))) +#+end_src + +** Harness Logs (context-logs) + +Retrieves the most recent lines from the harness's internal log buffer. The log limit is configurable via ~CONTEXT_LOG_LIMIT~ env var (default 20). + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-logs (&optional limit) + "Retrieves the most recent lines from the harness's internal log." + (let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20))) + (bt:with-lock-held (*log-lock*) + (let ((count (min log-limit (length *log-buffer*)))) + (subseq *log-buffer* 0 count))))) +#+end_src + +** Backward-Compatibility Alias (context-get-system-logs) + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun context-get-system-logs (&optional limit) + "Backward-compatibility alias for context-logs." + (context-logs limit)) +#+end_src + +** AST to Org Rendering (context-object-render) + +Recursively renders an ~org-object~ and its children to an Org-mode string, applying the Foveal-Peripheral model: + +- Objects within depth 2 are always included (outline) +- The foveal object (the one the user is looking at) is always included with full content +- Objects with semantic similarity above the threshold are included with full content +- All other objects are omitted silently + +This function is the heart of the context assembly. Its performance directly affects the agent's response time. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-object-render (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil)) + "Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model." + (let* ((id (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)) +#+end_src + +** Path Resolution (context-path-resolve) + +Expands environment variables in a path string and strips quotes. Used to resolve configurable paths from ~.env~. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-path-resolve (path-string) + "Expands environment variables and strips literal quotes from a path string." + (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))) +#+end_src + +** Privacy Filter for Context Assembly + +Checks if an org-object has tags matching the Dispatcher's privacy tags. Objects with matching tags are excluded from the LLM's context window. This prevents private content tagged with ~@personal~ (or any user-configured privacy tag) from being included in prompts sent to external LLM providers. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-privacy-filtered-p (obj) + "Returns T if an org-object's :TAGS attribute matches 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))))) +#+end_src + +** Global Awareness (context-awareness-assemble) + +Produces the high-level skeletal outline of the current Memory that is included in every LLM call. This is the "peripheral vision" of the agent — it knows what projects exist, their titles and IDs, but not their full content. + +Privacy-filtered projects (those with tags matching the Dispatcher's privacy tags) are excluded from the output. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-awareness-assemble (&optional signal) + "Produces a high-level skeletal outline of the current Memory for the LLM. +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)) +#+end_src + +** Backward-Compatibility Alias + +The global awareness function was renamed from ~context-assemble-global-awareness~ +to ~context-awareness-assemble~. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun context-assemble-global-awareness () + (context-awareness-assemble)) +#+end_src + +** Skill Registration +#+begin_src lisp +(defskill :passepartout-symbolic-awareness + :priority 50 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) +#+end_src + +* Test Suite +Verifies that the Foveal-Peripheral rendering correctly distinguishes between foveal (detailed) and peripheral (outline) content, and that the awareness budget includes all active projects. +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-peripheral-vision-tests + (:use :cl :fiveam :passepartout) + (:export #:vision-suite)) +(in-package :passepartout-peripheral-vision-tests) + +(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.") +(in-suite vision-suite) + +(test test-foveal-rendering + "Contract 1: foveal content inline, peripheral content title-only." + (clrhash passepartout::*memory-store*) + (let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project")) + :contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node") + :raw-content "FOVEAL CONTENT" :contents nil) + (:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node") + :raw-content "PERIPHERAL CONTENT" :contents nil))))) + (ingest-ast ast) + (let ((output (context-awareness-assemble (list :foveal-focus "node-foveal")))) + (is (search "FOVEAL CONTENT" output)) + (is (search "* Peripheral Node" output)) + (is (not (search "PERIPHERAL CONTENT" output)))))) + +(test test-awareness-budget + "Contract 1: all active projects appear in awareness output." + (clrhash passepartout::*memory-store*) + (ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil)) + (ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil)) + (let ((output (context-awareness-assemble))) + (is (search "Project 1" output)) + (is (search "Project 2" output)))) + +(test test-context-empty-memory + "Contract 1: empty memory produces clean output without error." + (clrhash passepartout::*memory-store*) + (let ((output (context-awareness-assemble))) + (is (stringp output)) + (is (search "MEMEX" output :test #'char-equal)))) + +(test test-context-no-foveal-focus + "Contract 2: without foveal focus, no inline content appears." + (clrhash passepartout::*memory-store*) + (let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project")) + :contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node") + :raw-content "CHILD CONTENT" :contents nil))))) + (ingest-ast ast) + (let ((output (context-awareness-assemble nil))) + (is (stringp output)) + (is (not (search "CHILD CONTENT" output)))))) + +(test test-semantic-retrieval-trigram + "Contract v0.4.0: trigram backend produces non-zero similarity for related content." + (let ((v1 (passepartout::embedding-backend-trigram "implement user login form")) + (v2 (passepartout::embedding-backend-trigram "add password authentication"))) + (let ((sim (passepartout::vector-cosine-similarity v1 v2))) + (is (> sim 0.0)))) + (let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module")) + (v4 (passepartout::embedding-backend-trigram "authentication login form handler fix"))) + (let ((sim (passepartout::vector-cosine-similarity v3 v4))) + (is (> sim 0.75)))) + (let ((v5 (passepartout::embedding-backend-trigram "authentication")) + (v6 (passepartout::embedding-backend-trigram "banana"))) + (let ((sim (passepartout::vector-cosine-similarity v5 v6))) + (is (< sim 0.3))))) +#+end_src diff --git a/org/symbolic-config.org b/org/symbolic-config.org new file mode 100644 index 0000000..0a1fdcd --- /dev/null +++ b/org/symbolic-config.org @@ -0,0 +1,383 @@ +#+TITLE: SKILL: Config Manager (org-skill-config-manager.org) +#+AUTHOR: Agent +#+FILETAGS: :skill:setup:config: +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-config.lisp + +* Overview +The *Config Manager* skill provides the Passepartout Agent with the capability to manage its own environment variables and provider configurations. It includes an interactive setup wizard for LLM providers, gateways, and system settings. + +* Implementation + +** Configuration directory (config-directory) +Resolves the XDG config directory for Passepartout. +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun config-directory () + "Returns the absolute path to the opencortex config directory." + (let ((xdg (uiop:getenv "OC_CONFIG_DIR"))) + (if xdg xdg (namestring (merge-pathnames ".config/passepartout/" (user-homedir-pathname)))))) +#+end_src + +** Config file path (config-file-path) +Returns the path to the ~.env~ file within the config directory. +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun config-file-path () + "Returns the path to the .env configuration file." + (merge-pathnames ".env" (config-directory))) +#+end_src + +** Ensure config directory (config-directory-ensure) +Creates the config directory tree if it does not exist. +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun config-directory-ensure () + "Creates the configuration directory if it does not exist." + (ensure-directories-exist (config-directory))) +#+end_src + +** Config File Operations +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun config-read () + "Reads the .env config file and returns an alist of KEY=VALUE pairs." + (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))))) + +#+end_src +** config-write +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun config-write (config-alist) + "Writes the config alist to the .env file." + (config-directory-ensure) + (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)))))) + +#+end_src +** config-get +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun config-get (key) + "Gets a config value by key." + (let ((config (config-read))) + (cdr (assoc key config :test #'string=)))) + +#+end_src +** config-set +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun config-set (key value) + "Sets a config value and saves to file." + (let ((config (config-read)) + (pair (cons key value))) + (let ((existing (assoc key config :test #'string=))) + (if existing + (setf (cdr existing) value) + (push pair config)) + (config-write config)))) +#+end_src +#+end_src + +** Input Utilities +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun prompt (prompt-text) + "Simple prompt that returns user input as a string. +Returns nil if stdin is non-interactive." + (format t "~a" prompt-text) + (finish-output) + (ignore-errors (read-line))) + +#+end_src +** prompt-yes-no +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun prompt-yes-no (prompt-text) + "Prompts yes/no question. Returns T for yes, nil for no." + (let ((response (prompt (format nil "~a [Y/n]: " prompt-text)))) + (or (string= response "") + (string-equal response "Y") + (string-equal response "y") + (string-equal response "yes")))) + +#+end_src +** prompt-choice +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun prompt-choice (prompt-text options) + "Prompts user to choose from a list of options. Returns the chosen option or nil." + (format t "~a~%" prompt-text) + (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))))) +#+end_src +#+end_src + +** LLM Provider Setup +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(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"))) + +#+end_src +** Provider descriptions (for setup wizard display) + +These are shown inline when the user runs the setup wizard, so they know what they are choosing. + +| Provider | Description | Where to sign up | Recommendation | +|----------|-------------|------------------|--------------| +| ~OpenRouter~ | Free tier with 33+ models. No credit card required. Routes to best available free model. | openrouter.ai | ★ Recommended for new users | +| ~OpenAI~ | GPT-4o-mini and GPT-4o. Requires billing. | platform.openai.com | | +| ~Anthropic~ | Claude 3.5 Sonnet. Strong reasoning. | console.anthropic.com | | +| ~Groq~ | Very fast inference, free tier available. | console.groq.com | | +| ~Gemini~ | Google's Gemini models. Free tier via API. | aistudio.google.com | | +| ~DeepSeek~ | Competitive pricing, strong coding. | platform.deepseek.com | | +| ~NVIDIA~ | NVIDIA NIM. Hosted models, slower but capable. | build.nvidia.com | | +| ~Local~ | Any OpenAI-compatible local server (llama.cpp, vLLM, LM Studio, Ollama). No API key needed. | Run locally | | + +** setup-llm-providers +;; REPL-VERIFIED: 2026-05-04 +#+begin_src lisp +(defun setup-llm-providers () + "Interactive wizard for configuring LLM providers." + (format t "~%~%") + (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 "~%"))) + + + + +#+end_src +** setup-add-provider +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun setup-add-provider () + "Entry point for adding a single provider (called from CLI)." + (setup-llm-providers)) +#+end_src +#+end_src + +** Gateway Setup +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun setup-gateways () + "Interactive wizard for configuring external gateways." + (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 "~%")) +#+end_src + +** Skill Management +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(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 "~%")) +#+end_src + +** Memory Settings +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(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 "~%")) +#+end_src + +** Network Settings +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(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 "~%")) +#+end_src + +** Main Setup Wizard +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun setup-wizard-run () + "Main entry point for the interactive setup wizard." + (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 "~%")) +#+end_src + +** Skill Registration +#+begin_src lisp +(defskill :passepartout-system-config + :priority 100 + :trigger (lambda (ctx) (declare (ignore ctx)) nil)) +#+end_src \ No newline at end of file diff --git a/org/symbolic-diagnostics.org b/org/symbolic-diagnostics.org new file mode 100644 index 0000000..03d3977 --- /dev/null +++ b/org/symbolic-diagnostics.org @@ -0,0 +1,294 @@ +#+TITLE: SKILL: Diagnostics (org-skill-diagnostics.org) +#+AUTHOR: Agent +#+FILETAGS: :system:diagnostics:doctor: +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-diagnostics.lisp + +* Why a Doctor? + +The Diagnostics skill is the self-knowledge of Passepartout. It answers "Is everything working?" by checking dependencies, environment variables, and LLM connectivity. Unlike the harness-level Doctor (which runs at boot and on CLI demand), this skill provides the Lisp-level diagnostic functions — defining what "healthy" means: which binaries must be present, which directories must exist, which API keys should be configured. + +* Phase A: Demand (Thinking) +** Why a Doctor? +The Doctor transforms opaque startup failures into actionable engineering reports. It ensures the Brain never attempts to boot in a compromised state. + +** Detection Invariant +Binary detection must use shell probing (`which`) to account for varying `$PATH` inheritance between interactive and headless sessions. + +* Phase B: Contract + +1. (diagnostics-dependencies-check): probes PATH for every binary in + ~*diagnostics-binaries*~. Returns T if all found, NIL if any missing. + Side-effect: populates ~*doctor-missing-deps*~. +2. (diagnostics-env-check): validates XDG directories exist. Returns T + if all critical dirs present, NIL otherwise. +3. (diagnostics-run-all &key auto-install): orchestrates 1-3. Returns + a plist with ~:deps~, ~:env~, ~:llm~ keys. Respects ~:auto-install nil~. + +* Phase C: Implementation (Build) + +** Package Context +#+begin_src lisp +(in-package :passepartout) +#+end_src + +** Global Configuration +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *diagnostics-binaries* '("sbcl" "emacs" "git") + "List of external binaries required for full system operation.") + +#+end_src +** *diagnostics-package-map* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *diagnostics-package-map* + '(("sbcl" . "sbcl") + ("emacs" . "emacs") + ("git" . "git") + ("curl" . "curl") + ("rlwrap" . "rlwrap")) + "Map binary names to apt package names.") + +#+end_src +** *doctor-missing-deps* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *doctor-missing-deps* nil + "List of missing dependencies populated by diagnostics-dependencies-check.") + +#+end_src +** *doctor-auto-install* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *doctor-auto-install* t + "When T, doctor will attempt to install missing dependencies automatically.") +#+end_src +#+end_src + +** Dependency Verification +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun diagnostics-dependencies-check () + "Verifies that required external binaries are available in the PATH via shell probe." + (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)) +#+end_src + +** Auto-Install Dependencies +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun diagnostics-dependencies-install () + "Attempts to install missing system dependencies via apt." + (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))))) +#+end_src + +** XDG Environment Validation +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun diagnostics-env-check () + "Validates XDG directories and environment configuration." + (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)) +#+end_src + +** LLM Connectivity +The doctor checks all supported LLM providers and detects local Ollama instances. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun diagnostics-llm-check () + "Tests connectivity to LLM providers. Returns T if at least one provider is configured." + (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)))) +#+end_src + +** Orchestration +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun diagnostics-run-all (&key (auto-install t)) + "Executes the full diagnostic suite and returns T if system is healthy." + (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 +#+end_src + +** CLI Entry Point +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun diagnostics-main () + "Entry point for the 'doctor' CLI command." + (if (diagnostics-run-all) + (uiop:quit 0) + (uiop:quit 1))) +#+end_src + +* Phase D: Verification (Testing) + +#+begin_src lisp +(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)))))) +#+end_src + +* Phase E: Lifecycle +The doctor skill should be loaded early (priority 100) to validate system health before other skills initialize. + +** Skill Registration +#+begin_src lisp +(defskill :passepartout-system-diagnostics + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) +#+end_src \ No newline at end of file diff --git a/org/symbolic-events.org b/org/symbolic-events.org new file mode 100644 index 0000000..5771656 --- /dev/null +++ b/org/symbolic-events.org @@ -0,0 +1,350 @@ +#+TITLE: SKILL: Event Orchestrator (symbolic-events.org) +#+AUTHOR: Agent +#+FILETAGS: :system:orchestrator:hooks:cron: +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-events.lisp + +* Architectural Intent + +The Event Orchestrator unifies three control-plane mechanisms that were previously scattered across the system: + +1. **Hooks** — actions triggered when Org nodes with specific ~#+HOOK:~ properties are modified +2. **Cron** — time-based scheduled jobs using Org-mode timestamp repeat expressions +3. **Routing** — three-tier complexity classifier that decides whether a job needs the LLM at all + +Before the Orchestrator, each of these was handled ad-hoc. The heartbeat thread injected raw ~:heartbeat~ signals that skills had to parse themselves. Memory auto-save was a hardcoded counter in ~core-loop~. There was no way to say "when this file changes, verify its integrity" or "archive old tasks every Sunday." + +The Orchestrator attaches to the heartbeat as a deterministic gate (same pattern as the Dispatcher, the Archivist, and every other heartbeat-driven skill). On each tick, it checks the cron registry for due jobs and dispatches them at the appropriate tier. + +** The three tiers: + +| Tier | LLM? | Mechanism | Example | +|------|------|-----------|---------| +| ~:reflex~ | No | Direct function call | "Run integrity check" | +| ~:cognition~ | Light | Injected as user-input | "Summarize today's notes" | +| ~:reasoning~ | Full | Injected as user-input | "Plan the project architecture" | + +The default classifier uses keywords in the context to determine the tier: ~rm~, ~write-file~, ~shell~ → ~:reflex~; ~summarize~, ~list~, ~find~ → ~:cognition~; everything else → ~:reasoning~. This can be overridden by setting ~*tier-classifier*~ to a custom function. + +* Implementation + +** Package definition + +#+begin_src lisp +(defpackage :passepartout.system-event-orchestrator + (: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.system-event-orchestrator) +#+end_src + +** Registries + +The hook registry maps Org-mode property names (like ~verify-integrity~ from a ~#+HOOK: verify-integrity~ headline property) to lists of gate function symbols. When a node with that hook is modified, the orchestrator calls each gate in sequence. + +The cron registry maps job names (keywords like ~:weekly-report~) to configuration plists. Each entry contains the repeat expression, the action function, and the dispatch tier. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *hook-registry* (make-hash-table :test 'equal) + "Maps hook property string → list of gate function symbols.") + +#+end_src +** *cron-registry* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *cron-registry* (make-hash-table :test 'equal) + "Maps job name string → plist (:next-run :expression :repeat :action :tier).") + +#+end_src +** *tier-classifier* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *tier-classifier* nil + "Optional function (context) → :reflex | :cognition | :reasoning.") +#+end_src +#+end_src + +** Default tier classifier + +Uses keyword matching on the context text to determine which tier to dispatch at. The matching is deliberately coarse — it's a heuristic, not an exact science. Users who need precise control can set ~*tier-classifier*~ to their own function. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun default-classifier (context) + "Rule-based tier classification. +: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)))) +#+end_src + +** Parsing Org-mode repeat timestamps + +Org-mode timestamps use the format ~+<2026-05-02 Sat +1w>~ for repeating events. The ~+1w~ means "repeat every week," ~+1d~ means "every day," etc. This function extracts the repeat unit and value. + +Returns ~(UNIT VALUE)~ like ~(:W 1)~ for weekly, or ~NIL~ if there's no repeat clause. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun parse-org-repeat (timestamp-string) + (let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string)) + (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))))) +#+end_src + +** Registering a hook + +Called at boot or when a new ~#+HOOK:~ property is discovered. Appends the gate function to the registry entry for that hook. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun orchestrator-register-hook (hook-property gate-function) + "Registers a deterministic gate to fire when an Org node with +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)) +#+end_src + +** Registering a cron job + +Each cron job has a name, an Org-mode timestamp with optional repeat, an action function, and a dispatch tier. The ~:next-run~ field is initialized to the current time so the job fires on the first heartbeat cycle (it will be rescheduled according to the repeat pattern after execution). + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun orchestrator-register-cron (name expression action-function tier) + "Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode +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))) +#+end_src + +** Dispatch + +Routes an action to the appropriate executor based on its tier. Reflex actions are called directly (deterministic, no LLM overhead). Cognition and reasoning actions are injected as user-input events, which triggers the normal Perceive → Reason → Act pipeline (but at different model tiers). + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun orchestrator-dispatch (action tier) + "Execute ACTION at the specified TIER." + (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)))) +#+end_src + +** Heartbeat handler + +Called on each heartbeat cycle. Checks the cron registry for jobs whose ~:next-run~ time has passed, dispatches them, and reschedules repeating jobs. + +The rescheduling computes the next run based on the repeat unit: ~:d~ (days), ~:w~ (weeks), ~:m~ (months), defaulting to ~:h~ (hours). This is deliberately simple — full calendar-aware scheduling (skip weekends, respect business hours) can be added later. + +Returns ~nil~ so it doesn't block the heartbeat signal from reaching other skills. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun orchestrator-on-heartbeat (context) + "Called on each heartbeat tick. Checks and dispatches due cron jobs." + (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)) +#+end_src + +** Bootstrap + +Scans all Org files in the memex for ~#+HOOK:~ and ~#+CRON:~ properties in +headline property drawers and auto-registers them. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun orchestrator-scan-org-file (filepath) + "Scans a single Org file for HOOK and CRON properties in property drawers. +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))) + +#+end_src +** orchestrator-bootstrap +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun orchestrator-bootstrap () + "Scans all Org files in the memex for #+HOOK: and #+CRON: properties +and registers them. Scans ~/memex/projects/ and ~/memex/system/ by default." + (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))) +#+end_src +#+end_src + +** Heartbeat Generation (events-start-heartbeat) + +The heartbeat generator was extracted from ~core-pipeline.lisp~ in v0.5.0. It creates a background thread that periodically injects ~:heartbeat~ signals into the pipeline. + +If heartbeat is corrupted or missing, the agent has no background ticks — no cron jobs, no auto-save. But it remains fully functional: degraded, not dead. This is the self-repair criterion. + +#+begin_src lisp +(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"))) *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")))) +#+end_src + +** Skill registration + +The orchestrator registers as a skill with low priority so it runs after critical skills (policy, dispatcher) but before the heartbeat processing. The trigger matches ~:heartbeat~ sensor events. + +#+begin_src lisp +(defskill :passepartout-system-event-orchestrator + :priority 80 + :trigger (lambda (ctx) + (eq (getf (getf ctx :payload) :sensor) :heartbeat)) + :deterministic (lambda (action context) + (declare (ignore action)) + (orchestrator-on-heartbeat context) + nil)) +#+end_src \ No newline at end of file diff --git a/org/symbolic-memory.org b/org/symbolic-memory.org new file mode 100644 index 0000000..80fdc93 --- /dev/null +++ b/org/symbolic-memory.org @@ -0,0 +1,92 @@ +#+TITLE: SKILL: Homoiconic Memory (org-skill-homoiconic-memory.org) +#+AUTHOR: Agent +#+FILETAGS: :harness:memory:homoiconic: +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-memory.lisp + +* Overview +Because Lisp is homoiconic (code is data), memory objects can be read as executable forms. This skill provides the bridge between the org-object store and live Lisp evaluation — it can serialize an org-object into an s-expression, evaluate it to reconstruct state, and store the result back as a new object. This is the foundation of the agent's ability to save, restore, and inspect its own cognitive state at runtime. + +* Implementation + +** Memory Inspection + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(in-package :passepartout) + +(defun memory-inspect (&key (type-filter nil) (todo-filter nil) (limit 10)) + "Returns a structured report of memory state. +Optional filters: TYPE-FILTER (keyword), TODO-FILTER (string). +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)))) +#+end_src + +** Skill Registration + +#+begin_src lisp +(defskill :passepartout-system-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)) +#+end_src diff --git a/org/symbolic-scope.org b/org/symbolic-scope.org new file mode 100644 index 0000000..b6c0ccd --- /dev/null +++ b/org/symbolic-scope.org @@ -0,0 +1,343 @@ +#+TITLE: SKILL: Context Manager (org-skill-context-manager.org) +#+AUTHOR: Agent +#+FILETAGS: :system:context:scoping: +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-scope.lisp + +* Overview + +The Context Manager provides stack-based project focusing. When the agent +"focuses" on a project, file paths resolve relative to it and memory queries +auto-filter by scope. This enables the agent to work within a bounded context +without being distracted by unrelated memory. + +The core provides the mechanism (=memory-object-scope=, =context-query= with +scope parameter). This skill provides the policy — what to focus on, what +scope means for each project, and how the stack is managed. + +* Implementation + +** Context Stack + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(in-package :passepartout) + +(defvar *context-stack* nil + "Stack of context plists. Each plist has :project, :base-path, :scope. +Top of stack (car) is the current context.") + +#+end_src +** *context-max-depth* +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defvar *context-max-depth* 10 + "Maximum context stack depth. Prevents runaway pushes.") +#+end_src +#+end_src + +** Context Accessors + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun current-context () + "Returns the current context plist, or nil if no context is set." + (car *context-stack*)) + +#+end_src +** current-scope +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun current-scope () + "Returns the current scope keyword (:memex/:session/:project). +Returns :memex when no context is set (defaults to global scope)." + (or (getf (current-context) :scope) :memex)) + +#+end_src +** current-project +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun current-project () + "Returns the current project name, or nil." + (getf (current-context) :project)) + +#+end_src +** current-base-path +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun current-base-path () + "Returns the current base path for file resolution, or nil." + (getf (current-context) :base-path)) + +#+end_src +** context-stack-depth +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-stack-depth () + "Returns the current depth of the context stack." + (length *context-stack*)) +#+end_src +#+end_src + +** Stack Operations + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun push-context (&key project base-path (scope :project)) + "Pushes a new context onto the stack. When focused on a project: +- File paths resolve relative to BASE-PATH +- Memory queries filter by SCOPE +- :memex scope objects remain visible (always global) +Returns the new context plist." + (when (>= (context-stack-depth) *context-max-depth*) + (log-message "CONTEXT: Stack depth limit reached (~d), refusing push" *context-max-depth*) + (return-from push-context (current-context))) + (let* ((context (list :project project + :base-path base-path + :scope scope))) + (push context *context-stack*) + (context-save) + (log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth)) + context)) + +#+end_src +** pop-context +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun pop-context () + "Pops the current context, restoring the previous one. +Returns the restored context or nil if stack becomes empty." + (if *context-stack* + (let ((popped (pop *context-stack*))) + (context-save) + (log-message "CONTEXT: Popped ~a (depth ~d)" + (getf popped :project) (context-stack-depth)) + (current-context)) + (progn + (log-message "CONTEXT: Cannot pop — stack is empty") + nil))) + +#+end_src +** with-context +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defmacro with-context ((&key project base-path (scope :project)) &body body) + "Executes BODY within a scoped context, then restores the previous context. +Example: + (with-context (:project \"passepartout\" :base-path \"/home/user/memex/projects/passepartout\") + (context-scoped-query :tag \"bug\"))" + `(let ((*context-stack* (cons (list :project ,project + :base-path ,base-path + :scope ,scope) + *context-stack*))) + ,@body)) +#+end_src +#+end_src + +** Path Resolution + +Resolves file paths relative to the current project's base path. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun resolve-path (path) + "Resolves a file path relative to the current context. +If PATH is absolute, returns it unchanged. +If PATH is relative and a base-path is set, merges them. +Otherwise returns PATH unchanged." + (let ((base (current-base-path))) + (if (and base path (not (uiop:absolute-pathname-p path))) + (namestring (merge-pathnames path (uiop:ensure-directory-pathname base))) + path))) +#+end_src + +** Memory Scope Filtering + +Provides scope-aware query access. When a context is active (scope ≠ :memex), +queries only return objects whose scope is :memex (global) or matches the +current scope. + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun context-scoped-query (&key tag todo-state type) + "Like context-query but filtered to the current context's scope. +:memex-scoped objects are always visible regardless of current scope." + (context-query :tag tag :todo-state todo-state :type type :scope (current-scope))) + +#+end_src +** project-objects +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun project-objects () + "Returns all objects scoped to the current project. +Includes :memex-scoped objects (global knowledge) plus :project-scoped +objects matching the current project." + (context-scoped-query)) +#+end_src +#+end_src + +** Project Focus Convenience + +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun focus-project (name base-path) + "Shortcut: focus on a project by name and base path. +Calls push-context with :scope :project." + (push-context :project name :base-path base-path :scope :project)) + +#+end_src +** focus-session +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun focus-session () + "Shortcut: enter a session context (ephemeral scope). +Objects created in this scope are visible only during the session." + (push-context :project "session" :scope :session)) + +#+end_src +** focus-memex +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun focus-memex () + "Shortcut: return to global memex scope. Equivalent to pop-context +until stack is empty or :memex context is reached." + (loop while (and *context-stack* + (not (eq (getf (current-context) :scope) :memex))) + do (pop-context))) + +#+end_src +** unfocus +;; REPL-VERIFIED: 2026-05-03T13:00:00 +#+begin_src lisp +(defun unfocus () + "Pop the top context and return to the previous one." + (pop-context)) +#+end_src +#+end_src + +** Skill Registration + +** Persistence + +;; REPL-VERIFIED: 2026-05-05T12:00:00 +#+begin_src lisp +(defvar *context-persistence-file* nil + "Path to the context stack persistence file.") + +(defun context-persist-file () + "Returns the full path to the context persistence file." + (or *context-persistence-file* + (setf *context-persistence-file* + (merge-pathnames ".cache/passepartout/context.lisp" + (user-homedir-pathname))))) + +(defun context-save () + "Writes *context-stack* to the persistence file." + (handler-case + (let ((path (context-persist-file))) + (ensure-directories-exist (make-pathname :directory (pathname-directory path))) + (with-open-file (s path :direction :output :if-exists :supersede + :if-does-not-exist :create) + (prin1 *context-stack* s)) + (log-message "CONTEXT: Saved stack (depth ~d) to ~a" + (length *context-stack*) path)) + (error (c) + (log-message "CONTEXT: Failed to save: ~a" c)))) + +(defun context-load () + "Restores *context-stack* from the persistence file." + (handler-case + (let ((path (context-persist-file))) + (when (probe-file path) + (with-open-file (s path :direction :input) + (let ((*read-eval* nil) + (data (read s nil nil))) + (when (listp data) + (setf *context-stack* data) + (log-message "CONTEXT: Restored stack (depth ~d) from ~a" + (length *context-stack*) path)) + t)))) + (error (c) + (log-message "CONTEXT: Failed to load: ~a" c) + nil))) +#+end_src + +** Skill Registration + +#+begin_src lisp +(defskill :passepartout-system-context-manager + :priority 90 + :trigger (lambda (ctx) (declare (ignore ctx)) nil) + :deterministic (lambda (action ctx) + (declare (ignore action)) + (ignore-errors + (when (> (context-stack-depth) 0) + nil)) + nil)) +#+end_src + +** Auto-Init: Wire Scope Resolver + +Registers ~current-scope~ into the core ~*scope-resolver*~ hook so the +perceive gate tags ingested objects with the active context scope. +Also restores any previously saved context stack. + +#+begin_src lisp +(when (boundp '*scope-resolver*) + (setf *scope-resolver* #'current-scope)) + +;; Restore persisted context on load +(context-load) +#+end_src + +* Contract + +1. (push-context &key project base-path scope): pushes a context plist + onto ~*context-stack*~ and persists to disk. +2. (pop-context): pops the top context, persists, returns restored context. +3. (context-save): serializes ~*context-stack*~ to the persistence file. +4. (context-load): restores ~*context-stack*~ from persistence file on boot. + +* Test Suite +#+begin_src lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) + +(defpackage :passepartout-context-tests + (:use :cl :passepartout) + (:export #:context-suite)) + +(in-package :passepartout-context-tests) + +(fiveam:def-suite context-suite :description "Context manager verification") +(fiveam:in-suite context-suite) + +(fiveam:test test-push-pop-context + "Contract 1-2: push-context and pop-context maintain stack order." + (let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER")) + (stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg))) + (pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg)))) + (when stack-var + (setf (symbol-value stack-var) nil) + (push-context :project "testapp" :base-path "/tmp" :scope :project) + (fiveam:is (= 1 (length (symbol-value stack-var)))) + (fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project))) + (pop-context) + (fiveam:is (null (symbol-value stack-var)))))) + +(fiveam:test test-context-save-load + "Contract 3-4: context-save and context-load round-trip." + (let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER")) + (stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg))) + (pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg)))) + (when (and stack-var pf-var) + (let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory)))) + (setf (symbol-value pf-var) tmpfile) + (setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project))) + (context-save) + (fiveam:is (probe-file tmpfile)) + (setf (symbol-value stack-var) nil) + (context-load) + (fiveam:is (= 1 (length (symbol-value stack-var)))) + (fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project))) + (ignore-errors (delete-file tmpfile)))))) +#+end_src \ No newline at end of file diff --git a/org/symbolic-self-improve.org b/org/symbolic-self-improve.org new file mode 100644 index 0000000..8219643 --- /dev/null +++ b/org/symbolic-self-improve.org @@ -0,0 +1,280 @@ +#+TITLE: SKILL: Self-Improve (org-skill-self-improve.org) +#+AUTHOR: Agent +#+FILETAGS: :system:autonomy:self-improve: +#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-self-improve.lisp + +* Overview: Self-Modification Primitives + +Self-Improve combines the former Self-Edit and Self-Fix skills into a unified +self-modification subsystem. It provides surgical text editing of source files +with rollback safety, and automated error diagnosis and repair for failing skills. + +The unified name reflects the merged architecture: editing a file and fixing an +error are both self-improvement operations — the system inspecting and modifying +its own implementation while running. + +* Implementation + +** Infrastructure: Org Tangle Utility + +Reads an Org file's ~#+PROPERTY: header-args:lisp :tangle~ line, extracts +all ~#+begin_src lisp~ blocks, writes them to the target ~.lisp~ file, and +compiles+loads the result. Used by the self-improve functions to propagate +edits and repairs to the running daemon. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun org-tangle-file (filepath) + "Tangles an Org file's lisp blocks to its :tangle target, compiles, and loads." + (let ((content (uiop:read-file-string filepath)) + (tangle-path nil) + (lisp-lines nil) + (in-block nil)) + (dolist (line (uiop:split-string content :separator '(#\Newline))) + (let ((trimmed (string-trim '(#\Space #\Tab) line))) + (cond + ((and (null tangle-path) + (search "#+PROPERTY:" trimmed) + (search ":tangle" trimmed)) + (let* ((parts (uiop:split-string trimmed :separator '(#\Space))) + (target (car (last parts))) + (org-dir (make-pathname :directory (pathname-directory filepath)))) + (when (and target (not (string-equal target "no"))) + (setf tangle-path + (if (char= (aref target 0) #\/) + (uiop:parse-unix-namestring target) + (uiop:parse-unix-namestring + (format nil "~a/~a" (namestring org-dir) target))))))) + ((search "#+begin_src lisp" trimmed) + (setf in-block t)) + ((search "#+end_src" trimmed) + (setf in-block nil) + (let ((before (search "#+end_src" line))) + (when (and before (> before 0)) + (push (subseq line 0 before) lisp-lines)))) + (in-block + (push line lisp-lines))))) + (when (and tangle-path lisp-lines) + (setf lisp-lines (nreverse lisp-lines)) + (ensure-directories-exist tangle-path) + (with-open-file (f tangle-path :direction :output :if-exists :supersede) + (format f "~{~a~%~}" lisp-lines)) + (let ((compiled (compile-file tangle-path))) + (when compiled + (load compiled) + (list :tangled (namestring tangle-path) :compiled t)))))) +#+end_src + +** Infrastructure: Org Lisp Block Extractor + +Extracts all ~#+begin_src lisp~ block contents from an Org content string, +returning a list of code strings. Used by repair functions to iterate over +blocks and apply syntactic fixes. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun org-extract-lisp-blocks (content) + "Extracts all #+begin_src lisp blocks from Org CONTENT as a list of strings." + (let ((blocks nil) + (in-block nil) + (current nil)) + (dolist (line (uiop:split-string content :separator '(#\Newline))) + (let ((trimmed (string-trim '(#\Space #\Tab) line))) + (cond + ((search "#+begin_src lisp" trimmed) + (setf in-block t current nil)) + ((search "#+end_src" trimmed) + (when in-block + (let ((before (search "#+end_src" line))) + (when (and before (> before 0)) + (push (subseq line 0 before) current))) + (push (format nil "~{~a~%~}" (nreverse current)) blocks) + (setf in-block nil current nil))) + (in-block + (push line current))))) + (nreverse blocks))) +#+end_src + +** Self-Edit: Surgical Text Transformation + +Applies a search-and-replace edit to a file, verifies the edit took effect, +and if the file is an ~.org~ file, automatically tangles it to ~.lisp~ and +reloads the compiled result into the running daemon. A memory snapshot is +taken before the edit for rollback safety. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun self-improve-edit (filepath old-text new-text) + "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))))) +#+end_src + +** Paren Balancer + +Utility that attempts to fix unbalanced parentheses in a Lisp code string. +If the code is already balanced, returns nil. Otherwise counts open vs close +parens and appends missing closing parens. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun self-improve-balance-parens (code) + "Returns balanced code or nil if already balanced." + (handler-case + (progn + (let ((*read-eval* nil)) + (with-input-from-string (s code) + (loop for form = (read s nil :eof) until (eq form :eof))) + (values)) + nil) + (error () + (let* ((opens (loop for ch across code count (char= ch #\())) + (closes (loop for ch across code count (char= ch #\)))) + (missing (- opens closes))) + (when (plusp missing) + (concatenate 'string code + (make-string missing :initial-element #\)))))))) +#+end_src + +** Syntax Repair Driver + +Given a skill name, locates its ~.org~ source file, extracts all Lisp blocks, +runs each through the paren balancer, writes fixes back to the file, tangles, +compiles, and reloads. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun self-improve-repair-syntax (skill-name) + "Find and fix unbalanced parens in a skill's Org source file." + (let* ((data-dir (uiop:ensure-directory-pathname + (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") + (merge-pathnames ".local/share/passepartout/" + (user-homedir-pathname))))) + (org-path (merge-pathnames (format nil "org/~a.org" skill-name) data-dir))) + (unless (uiop:file-exists-p org-path) + (return-from self-improve-repair-syntax + (list :status :error :reason (format nil "Source not found: ~a" skill-name) + :repaired nil))) + (let* ((content (uiop:read-file-string org-path)) + (blocks (org-extract-lisp-blocks content)) + (fixed 0) (result content)) + (dolist (block blocks) + (let ((balanced (self-improve-balance-parens block))) + (when (and balanced (not (string= block balanced))) + (let ((pos (search block result))) + (when pos + (setf result (concatenate 'string + (subseq result 0 pos) + balanced + (subseq result (+ pos (length block)))) + fixed (1+ fixed))))))) + (if (> fixed 0) + (progn + (with-open-file (f org-path :direction :output :if-exists :supersede) + (write-sequence result f)) + (let ((tangle-result (org-tangle-file org-path))) + (list :status :success + :action (format nil "Fixed ~d block(s) in ~a" fixed skill-name) + :repaired t :tangle tangle-result))) + (list :status :error + :reason (format nil "No unbalanced blocks in ~a" skill-name) + :repaired nil))))) +#+end_src + +** Self-Fix: Error Diagnosis and Repair + +Parses an error log to diagnose the error type, then dispatches to the +appropriate repair function. Currently supports syntax error repair +(unbalanced parentheses). Other error types return a diagnosis without +automatic repair. + +;; REPL-VERIFIED: 2026-05-03T14:00:00 +#+begin_src lisp +(defun self-improve-fix (skill-name error-log) + "Diagnoses and attempts to repair a failing skill." + (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))))) +#+end_src + +** Skill Registration + +Registered with a trigger on ~:LOG~ and ~:EVENT~ context types. The +deterministic gate returns nil (pass-through) — self-improve runs as a +diagnostic observer, not a blocking gate. + +#+begin_src lisp +(defskill :passepartout-system-self-improve + :priority 100 + :trigger (lambda (ctx) (member (getf ctx :type) '(:LOG :EVENT))) + :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) +#+end_src diff --git a/org/system-integration-tests.org b/org/system-integration-tests.org deleted file mode 100644 index 7caf08e..0000000 --- a/org/system-integration-tests.org +++ /dev/null @@ -1,504 +0,0 @@ -#+TITLE: SKILL: System Integration Tests -#+AUTHOR: Agent -#+PROPERTY: header-args:lisp :tangle ../lisp/system-integration-tests.lisp - -* Architectural Intent - -Integration tests verify that modules work together over real boundaries — -TCP sockets, file I/O, subprocess execution, and the full daemon pipeline. -Unlike unit tests (which mock collaborators), integration tests start a real -daemon, connect like a real client, and assert observable behavior. - -** Contract - -Phase 1 — In-process daemon (no external credentials): - -1. (start-daemon &key port): binds port, sends handshake on connect. -2. Pipeline: a ~:user-input~ event traverses the full pipeline. -3. Communication: framed messages survive TCP round-trip; malformed input - does not crash the daemon. -4. Skill loader: after daemon start, ~*skill-registry*~ is populated. -5. Shell actuator: safe commands execute; dangerous patterns are blocked. -6. CLI gateway: text injected via TCP reaches the pipeline. -7. Gateway registry: ~gateway-registry-initialize~ is available. - -Phase 2 — LLM + messaging: - - 8. Provider cascade: ~PROVIDER_CASCADE~ entries are clean keywords - matching registered backends (no quote contamination). - 9. Backend cascade: real provider returns string content. - -Phase 3 — TUI via tmux (rendering diagnostics): - - 10. Cascade inspection: ~/eval *provider-cascade*~ shows clean keywords - on TUI screen (no quote artifacts from cl-dotenv). - 11. Eval command: ~/eval (+ 1 2)~ displays ~~=> 3~~ on screen. - 12. Status bar: rendered screen shows ~~msgs:~~ in status bar. - 13. Direct render: ~/eval (add-msg :agent ...)~ renders text on screen - independent of daemon — isolates TUI rendering from pipeline. - 14. Daemon roundtrip: daemon LLM response stored in TUI ~~:messages~~ - list as ~~:agent~~ entry — isolates daemon→TUI communication. - 15. Full render: agent response text appears on rendered screen - after LLM roundtrip — tests complete TUI→daemon→LLM→TUI pipeline. - -** Boundaries - -- Requires ~passepartout setup~ to have been run (skills in XDG data dir). -- Phase 2 tests skip if required env vars are unset. -- Phase 3 tests require tmux and Emacs installed. - -* Prologue - -Shared test harness: package, suite, helpers, and ~with-daemon~. - -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t) - (ql:quickload :usocket :silent t)) - -(defpackage :passepartout-integration-tests - (:use :cl :passepartout) - (:export #:integration-suite)) - -(in-package :passepartout-integration-tests) - -(fiveam:def-suite integration-suite :description "Integration tests across process boundaries") -(fiveam:in-suite integration-suite) - -(defvar *daemon-port* nil) - -(defun find-free-port () - (let ((socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t))) - (unwind-protect (usocket:get-local-port socket) - (usocket:socket-close socket)))) - -(defmacro with-daemon (() &body body) - `(let ((*daemon-port* (find-free-port))) - (unwind-protect - (progn - (passepartout:actuator-initialize) - (passepartout:skill-initialize-all) - (passepartout:start-daemon :port *daemon-port*) - (sleep 2) - ,@body) - (values))) - -(defun daemon-connect () - (let* ((sock (usocket:socket-connect "127.0.0.1" *daemon-port*)) - (stream (usocket:socket-stream sock))) - (read-framed-message stream) ;; discard handshake - (values stream sock))) - -(defun daemon-send (stream msg) - (write-string (frame-message msg) stream) - (finish-output stream)) - -(defun daemon-recv (stream &key (timeout 5)) - (let ((deadline (+ (get-universal-time) timeout))) - (loop - (when (listen stream) - (return (read-framed-message stream))) - (when (> (get-universal-time) deadline) (return nil)) - (sleep 0.1)))) -#+end_src - -* Daemon Lifecycle - -Verifies the daemon starts, binds its port, and sends a valid handshake. - -#+begin_src lisp -(fiveam:test test-daemon-starts - "Contract 1: daemon binds port and sends valid handshake." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (is (open-stream-p stream)) - (usocket:socket-close sock)))) -#+end_src - -* Pipeline End-to-End - -Sends a ~:user-input~ event and verifies the pipeline produces a response. - -#+begin_src lisp -(fiveam:test test-pipeline-user-input - "Contract 2: :user-input traverses pipeline and produces a response." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (unwind-protect - (progn - (daemon-send stream - '(:TYPE :EVENT :PAYLOAD (:SENSOR :user-input :TEXT "test"))) - (let ((resp (daemon-recv stream :timeout 10))) - (is (not (null resp)) "Expected a response"))) - (usocket:socket-close sock))))) - -(fiveam:test test-pipeline-heartbeat - "Contract 2: heartbeat signals do not crash the daemon." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (unwind-protect - (daemon-send stream - '(:TYPE :EVENT :PAYLOAD (:SENSOR :heartbeat))) - (usocket:socket-close sock)) - (pass)))) -#+end_src - -* Communication Protocol - -Verifies framed TCP round-trip and malformed-input resilience. - -#+begin_src lisp -(fiveam:test test-tcp-round-trip - "Contract 3: framed health-check survives TCP round-trip." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (unwind-protect - (progn - (daemon-send stream '(:TYPE :health-check)) - (let ((resp (daemon-recv stream :timeout 5))) - (is (not (null resp))) - (is (member (getf resp :type) '(:HEALTH-RESPONSE))))) - (usocket:socket-close sock))))) - -(fiveam:test test-daemon-survives-junk - "Contract 3: daemon does not crash on junk input." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (write-string "ZZZZZZ" stream) - (finish-output stream) - (sleep 1) - (usocket:socket-close sock)) - ;; Connect again to verify daemon is still alive - (multiple-value-bind (stream2 sock2) (daemon-connect) - (is (open-stream-p stream2)) - (usocket:socket-close sock2)))) -#+end_src - -* Skill Loader - -Verifies the skill loader populates ~*skill-registry*~ after daemon start. - -#+begin_src lisp -(fiveam:test test-skill-registry-populated - "Contract 4: *skill-registry* is populated after daemon start." - (with-daemon () - (is (hash-table-p passepartout::*skill-registry*)) - (is (>= (hash-table-count passepartout::*skill-registry*) 1) - "Expected at least 1 skill in registry, got ~a" - (hash-table-count passepartout::*skill-registry*)))) -#+end_src - -* Shell Actuator - -Verifies safe shell commands execute and dangerous patterns are blocked. - -#+begin_src lisp -(fiveam:test test-shell-safe-echo - "Contract 5: safe shell command does not crash the daemon." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (unwind-protect - (daemon-send stream - '(:TYPE :REQUEST :TARGET :shell - :PAYLOAD (:ACTION :execute :CMD "echo hello"))) - (usocket:socket-close sock)) - (pass)))) - -(fiveam:test test-shell-dangerous-blocked - "Contract 5: rm -rf / is blocked by the security dispatcher." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (unwind-protect - (daemon-send stream - '(:TYPE :REQUEST :TARGET :shell - :PAYLOAD (:ACTION :execute :CMD "rm -rf /"))) - (usocket:socket-close sock)) - (pass)))) -#+end_src - -* CLI Gateway - -Verifies text input over TCP reaches the pipeline. - -#+begin_src lisp -(fiveam:test test-cli-gateway-input - "Contract 6: text via TCP produces a response." - (with-daemon () - (multiple-value-bind (stream sock) (daemon-connect) - (unwind-protect - (daemon-send stream - '(:TYPE :EVENT :META (:SOURCE :CLI) - :PAYLOAD (:SENSOR :user-input :TEXT "hello from CLI"))) - (usocket:socket-close sock)) - (pass)))) -#+end_src - -* Gateway Registry - -Verifies the gateway registry function is available after daemon start. - -#+begin_src lisp -(fiveam:test test-gateway-registry - "Contract 7: gateway-registry-initialize is available." - (with-daemon () - (is (fboundp 'gateway-registry-initialize)) - (gateway-registry-initialize) - (pass))) -#+end_src - -* LLM Provider Cascade - -Tests backend-cascade-call and provider-openai-request with real API -credentials. Skipped silently if OPENROUTER_API_KEY is unset. - -#+begin_src lisp -(defun has-api-key (env-var) - "Returns T if env-var is set and non-empty." - (let ((val (uiop:getenv env-var))) - (and val (> (length val) 0)))) - -(defmacro skip-unless (env-var &body body) - "Execute body if env-var is set, otherwise skip the test." - `(if (has-api-key ,env-var) - (progn ,@body) - (progn - (format t " [SKIP] ~a not set~%" ,env-var) - (skip "~a not set" ,env-var)))) - -(fiveam:test test-provider-openai-request - "Contract Phase2: provider-openai-request returns :success with valid API key." - (skip-unless "OPENROUTER_API_KEY" - (let ((result (provider-openai-request "Say hello" "Be brief." - :provider :openrouter - :model "openrouter/auto"))) - (is (or (eq (getf result :status) :success) - (eq (getf result :status) :error)) - "Expected :success or :error, got: ~a" result)))) - -(fiveam:test test-backend-cascade-real - "Contract Phase2: backend-cascade-call returns string content with real provider." - (skip-unless "OPENROUTER_API_KEY" - (let ((passepartout::*provider-cascade* '(:openrouter))) - (let ((result (backend-cascade-call "Say hello" :system-prompt "Be brief."))) - (is (stringp result) "Expected string response, got: ~a" result))))) - -(fiveam:test test-provider-cascade-parsing - "Contract Phase2: PROVIDER_CASCADE env var parses to clean keywords matching backends." - (provider-cascade-initialize) - (let ((cascade passepartout::*provider-cascade*)) - (is (listp cascade) "Cascade must be a list") - (is (>= (length cascade) 1) "Cascade must have at least one entry") - (dolist (entry cascade) - (is (keywordp entry) "Entry ~s must be a keyword" entry) - (let ((name (symbol-name entry))) - (is (not (find #\" name)) "Entry ~s must not contain double-quote" entry) - (is (not (find #\' name)) "Entry ~s must not contain single-quote" entry))) - (is (some (lambda (e) (gethash e passepartout::*probabilistic-backends*)) cascade) - "At least one cascade entry must match a registered backend"))) -#+end_src - -* Messaging Link/Unlink - -Verifies messaging-link stores a token in the vault, gateway-configured-p -returns the correct status, and messaging-unlink removes it. No real -API credentials needed — these are management functions. - -#+begin_src lisp -(fiveam:test test-messaging-link-unlink - "Contract Phase2: messaging-link stores token, configured-p returns T, unlink removes it." - (with-daemon () - (messaging-link :test-platform :token "fake-token-123") - (is (gateway-configured-p :test-platform) - "Expected test-platform to be configured after linking") - (messaging-unlink :test-platform) - (is (not (gateway-configured-p :test-platform)) - "Expected test-platform to be unconfigured after unlinking"))) - -(fiveam:test test-gateway-configured-p-false - "Contract Phase2: gateway-configured-p returns nil for unknown platform." - (with-daemon () - (is (not (gateway-configured-p :nonexistent-platform-xyz))))) - -(fiveam:test test-gateway-start-messaging - "Contract Phase2: gateway registry initializes with expected platforms." - (with-daemon () - (gateway-registry-initialize) - (is (hash-table-p passepartout::*gateway-registry*)) - (is (>= (hash-table-count passepartout::*gateway-registry*) 1)))) -#+end_src - -* TUI Integration Shell Script - -Verifies the TUI end-to-end via tmux: input rendering, /eval, status bar, -connection drop. - -#+begin_src shell :tangle ../test/integration-tui.sh -#!/bin/bash -set -euo pipefail - -PASS=0 -FAIL=0 -WARN=0 -TUI_LOG="/tmp/passepartout-tui-test.log" -> "$TUI_LOG" - -cleanup() { - tmux kill-session -t tui-test 2>/dev/null || true -} -trap cleanup EXIT - -run_test() { - local name="$1"; shift - echo -n " $name ... " - if "$@" 2>/dev/null; then - echo "PASS" - PASS=$((PASS + 1)) - else - echo "FAIL" - FAIL=$((FAIL + 1)) - fi -} - -# ---- Setup ---- -echo "Starting TUI in tmux (daemon must already be running on port 9105)..." -tmux new-session -d -s tui-test "passepartout tui 2>&1 | tee $TUI_LOG" -for i in $(seq 1 20); do - sleep 3 - if tmux capture-pane -t tui-test -p 2>/dev/null | grep -q 'Connected'; then - echo " TUI ready after $((i*3))s" - break - fi - if [ "$i" -eq 20 ]; then - echo " WARNING: TUI did not render after 60s" - fi -done - -# ---- Tests ---- - -test_cascade_parsing() { - # Via /eval, check that *provider-cascade* contains clean keywords. - tmux send-keys -t tui-test "/eval *provider-cascade*" Enter - sleep 3 - local pane - pane=$(tmux capture-pane -t tui-test -p -S -15 2>/dev/null) - echo "$pane" | grep -q ':DEEPSEEK\|:OPENROUTER\|:OPENAI\|:ANTHROPIC\|:GROQ\|:GEMINI\|:NVIDIA' -} - -test_eval_command() { - tmux send-keys -t tui-test "/eval (+ 1 2)" Enter - sleep 3 - tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q '=> 3' -} - -test_status_bar() { - tmux capture-pane -t tui-test -p -S -20 2>/dev/null | grep -q 'msgs:' -} - -# ---- Diagnostic: rendering pipeline isolation ---- - -test_add_msg_render() { - # Stage A: can the TUI render an agent message at all? - # Inject a message directly via /eval — bypasses daemon entirely. - tmux send-keys -t tui-test "/eval (passepartout.gateway-tui:add-msg :agent \"RENDER-TEST-OK\")" Enter - sleep 2 - tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -q 'RENDER-TEST-OK' -} - -test_daemon_msg_roundtrip() { - # Stage B: does the daemon's LLM response reach the TUI's message list? - # Sends a message, waits, then checks via /eval that an :agent message exists. - tmux send-keys -t tui-test "Say hello" Enter - local before_ts - before_ts=$(date +%s) - while true; do - local result - result=$(tmux send-keys -t tui-test "/eval (loop for m in (passepartout.gateway-tui:st :messages) when (eq :agent (getf m :role)) return t)" Enter 2>/dev/null; sleep 3; tmux capture-pane -t tui-test -p -S -15 2>/dev/null | grep -o '=> [^ ]*' | tail -1) - if echo "$result" | grep -q '=> T'; then - return 0 - fi - local now_ts - now_ts=$(date +%s) - if (( now_ts - before_ts > 90 )); then - echo "TIMEOUT: no :agent msg in message list after 90s" >&2 - return 1 - fi - sleep 3 - done -} - -test_agent_response_renders() { - # Stage C: full end-to-end — LLM response appears on the rendered screen. - # Must show actual response text, not a cascade failure. - local before_ts - before_ts=$(date +%s) - tmux send-keys -t tui-test "Say hello in one word" Enter - while true; do - local pane - pane=$(tmux capture-pane -t tui-test -p -S -60 2>/dev/null) - if echo "$pane" | grep -qi 'hello\|hi there\|greeting\|hi[.!?]\|hey[.!?]'; then - if echo "$pane" | grep -qi 'cascade.*fail\|exhausted\|neural cascade'; then - echo "FAIL: agent responded with cascade failure, not LLM content" >&2 - return 1 - fi - return 0 - fi - local now_ts - now_ts=$(date +%s) - if (( now_ts - before_ts > 90 )); then - echo "TIMEOUT: no agent response on screen after 90s" >&2 - return 1 - fi - sleep 3 - done -} - -test_connection_drop() { - sleep 1 - tmux capture-pane -t tui-test -p -S -10 2>/dev/null | grep -qi 'connection.*lost\|ERROR.*Connection\|error.*connect' || true - return 0 -} - -run_test "cascade-parsing" test_cascade_parsing -run_test "eval-command" test_eval_command -run_test "status-bar" test_status_bar -run_test "add-msg-render" test_add_msg_render -run_test "daemon-msg-roundtrip" test_daemon_msg_roundtrip -run_test "agent-response-renders" test_agent_response_renders -run_test "connection-drop" test_connection_drop - -# ---- Summary ---- -echo "" -echo "===== $PASS passed, $FAIL failed, $WARN warnings =====" -exit $(( FAIL > 0 ? 1 : 0 )) -#+end_src - -* Emacs Integration - -Verifies Flight Plan message format and Emacs daemon connectivity. - -#+begin_src lisp -(fiveam:test test-flight-plan-message-format - "Contract Phase3: dispatcher-flight-plan-create returns valid message." - (with-daemon () - (load (merge-pathnames ".local/share/passepartout/lisp/security-dispatcher.lisp" - (user-homedir-pathname))) - (let ((plan (dispatcher-flight-plan-create - '(:TYPE :REQUEST :TARGET :shell :PAYLOAD (:CMD "sudo restart"))))) - (is (eq :REQUEST (getf plan :type))) - (is (eq :emacs (getf plan :target))) - (is (eq :insert-node (getf (getf plan :payload) :action))) - (let ((attrs (getf (getf plan :payload) :attributes))) - (is (string= "Flight Plan: High-Risk Action" (getf attrs :TITLE))) - (is (string= "PLAN" (getf attrs :TODO))) - (is (member "FLIGHT_PLAN" (getf attrs :TAGS) :test #'string-equal)))))) - -(fiveam:test test-emacs-daemon-connect - "Contract Phase3: Emacs daemon is reachable via emacsclient." - (handler-case - (let ((result (uiop:run-program '("emacsclient" "--eval" "(+ 1 2)") - :output :string - :ignore-error-status t))) - (is (search "3" result) "Expected '3' from emacsclient, got: ~a" result)) - (error (c) - (skip "Emacs daemon not available: ~a" c))))) -#+end_src diff --git a/passepartout b/passepartout index d145d67..6075dd8 100755 --- a/passepartout +++ b/passepartout @@ -357,9 +357,9 @@ case "$COMMAND" in nohup sbcl --non-interactive \ --eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \ --eval "(ql:quickload :passepartout)" \ - --eval "(load (format nil \"~alisp/system-model-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \ - --eval "(load (format nil \"~alisp/system-model-embedding.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \ - --eval "(load (format nil \"~alisp/system-model-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \ + --eval "(load (format nil \"~alisp/neuro-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \ + --eval "(load (format nil \"~alisp/embedding-backends.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \ + --eval "(load (format nil \"~alisp/neuro-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \ --eval '(funcall (find-symbol "MAIN" :passepartout))' \ > "$PASSEPARTOUT_STATE_DIR/daemon.log" 2>&1 & echo "Waiting for port 9105..." @@ -384,7 +384,7 @@ case "$COMMAND" in --eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \ --eval '(ql:quickload :passepartout/tui)' \ --eval '(in-package :passepartout)' \ - --eval '(handler-bind ((error (lambda (c) (format t "~%CRASH: ~a~%" c) (sb-debug:print-backtrace :count 30 :stream *error-output*) (finish-output) (finish-output *error-output*) (uiop:quit 1)))) (passepartout.gateway-tui:tui-main))' + --eval '(handler-bind ((error (lambda (c) (format t "~%CRASH: ~a~%" c) (sb-debug:print-backtrace :count 30 :stream *error-output*) (finish-output) (finish-output *error-output*) (uiop:quit 1)))) (passepartout.channel-tui:tui-main))' ;; gateway) SUBCMD=$1; PLATFORM=$2; TOKEN=$3 diff --git a/passepartout.asd b/passepartout.asd index bc3ddb4..2007a28 100644 --- a/passepartout.asd +++ b/passepartout.asd @@ -1,24 +1,23 @@ (defsystem :passepartout :name "Passepartout" :author "Amr Gharbeia" - :version "0.4.3" + :version "0.5.0" :license "AGPLv3" :description "The Probabilistic-Deterministic Lisp Machine" :depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid) :serial t - :components ((:file "lisp/core-defpackage") + :components ((:file "lisp/core-package") (:file "lisp/core-skills") - (:file "lisp/core-communication") + (:file "lisp/core-transport") (:file "lisp/core-memory") - (:file "lisp/core-context") - (:file "lisp/core-loop-perceive") - (:file "lisp/core-loop-reason") - (:file "lisp/core-loop-act") - (:file "lisp/core-loop"))) + (:file "lisp/core-perceive") + (:file "lisp/core-reason") + (:file "lisp/core-act") + (:file "lisp/core-pipeline"))) (defsystem :passepartout/tui :depends-on (:passepartout :croatoan :usocket :bordeaux-threads) :serial t - :components ((:file "lisp/gateway-tui-model") - (:file "lisp/gateway-tui-view") - (:file "lisp/gateway-tui-main"))) + :components ((:file "lisp/channel-tui-model") + (:file "lisp/channel-tui-view") + (:file "lisp/channel-tui-main")))