5 Commits

Author SHA1 Message Date
ae994fa452 v0.3.3: SIGWINCH, scroll clamp, /quit, /reconnect, history, message vector
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
SIGWINCH: handle KEY_RESIZE (410) in main loop — re-measure screen,
re-create status/chat/input windows at new dimensions, force redraw.

Scroll clamp: PageUp clamped to (max 0 (- total 1)), prevents scrolling
past message list end. Status bar shows 'msgs:N scroll:0'.

/quit: saves :input-history to ~/.cache/passepartout/history (one line
per entry, most recent first), sends goodbye handshake, sets :running nil.

/reconnect: closes stale socket via disconnect-daemon, re-runs
connect-daemon with retry backoff. Connection-loss detection: reader-loop
counts consecutive nils; after 10, queues :disconnected event. Handler
clears :connected/:busy, shows red system message.

Load-history: reads ~/.cache/passepartout/history on startup, populates
:input-history for up-arrow recall.

Message vector: :messages init as adjustable vector with fill pointer.
add-msg uses vector-push-extend (O(1) append). view-chat uses aref
(O(1) access) instead of nth (O(n) for lists).
2026-05-06 17:59:12 -04:00
9350cb855e v0.3.3: left/right cursor movement in input
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
Adds :cursor-pos to TUI state. New functions:
- input-insert-char(ch): insert at cursor position, advance cursor
- input-delete-char(): delete char before cursor (standard backspace)

on-key handlers:
- Left arrow: decrement cursor-pos (clamped >= 0)
- Right arrow: increment cursor-pos (clamped <= buffer-len)
- Character input: input-insert-char at cursor position
- Backspace: input-delete-char at cursor position
- Enter: reset cursor-pos to 0

view-input: cursor at visual position matching cursor-pos

Test: (init-state) → (input-insert-char #\h) → (input-insert-char #\i)
→ (setf cursor-pos 1) → (input-insert-char #\X) → 'hXi' at pos 2
2026-05-06 17:46:49 -04:00
0861ac26f1 v0.3.3: word wrap in view-chat — break at word boundaries
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 3s
Adds word-wrap(text width) — splits strings into lines at word
boundaries respecting terminal width. Rewrites view-chat to:
- Wrap each message with word-wrap before rendering
- Render each wrapped line as a separate add-string call
- Account for wrapped line count in visible-message calculation

RED proof: tmux capture shows messages split mid-word at terminal edge.
GREEN proof: tmux capture shows clean word-boundary wrapping:
  The quick brown fox jumps over the lazy dog while the cat naps
  peacefully in the sunny garden
2026-05-06 17:14:49 -04:00
4bed6dd461 v0.3.2: shell safety, :system :eval approval, skill sandbox
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 3s
1. Shell actuator: remove double bash -c wrapping (format ~s produces
   S-expression-safe strings, not shell-safe). Now passes cmd directly
   to (timeout N bash -c cmd) via run-program arg list.

2. Dispatcher: extend high-impact approval gate to :system :eval.
   Previously only :shell, :tool "shell", and :emacs :eval triggered
   HITL. Now :system :eval also requires Flight Plan approval.

3. Skill sandbox: before promoting a skill from its jailed package to
   :passepartout, scan for restricted symbol references (uiop:run-program,
   uiop:shell, uiop:run-shell-command). Block promotion on violation.
   New skill-entry status :sandbox-blocked for blocked skills.

Test: 91 pass, 0 fail across 13 suites.
2026-05-06 16:46:49 -04:00
a31f19045a v0.3.1: eliminate RCE via *read-eval* nil (Parser RCE Elimination)
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 3s
Wrap read-from-string/read with (let ((*read-eval* nil)) ...) at three
untrusted-input code paths:

1. think() in core-loop-reason — LLM output parsing. LLM output is
   untrusted by definition; #.(shell ...) in a response must not execute.

2. action-system-execute in core-loop-act — :system :eval path processes
   untrusted payload code from the signal pipeline.

3. load-memory-from-disk in core-memory — memory.snap file could be
   corrupted or planted in ~/, must not execute #. reader macros.

Adds test-read-eval-rce-blocked to pipeline-reason-suite: mocks a
backend returning malicious output containing #.(setf ...), verifies
no side effects occur and safe fallback is returned.

RED proof recorded: *read-eval* T + #.(setf ...) → :PWNED (RCE active)
GREEN proof:    *read-eval* NIL → reader-error caught (RCE blocked)

Test: reason 12/0, full suite 88/0
2026-05-06 16:38:59 -04:00
18 changed files with 530 additions and 198 deletions

View File

@@ -59,7 +59,7 @@
(cmd (getf payload :action))) (cmd (getf payload :action)))
(case cmd (case cmd
(:eval (:eval
(eval (read-from-string (getf payload :code)))) (eval (let ((*read-eval* nil)) (read-from-string (getf payload :code)))))
(:message (:message
(log-message "ACT [System]: ~a" (getf payload :text))) (log-message "ACT [System]: ~a" (getf payload :text)))
(t (t

View File

@@ -99,7 +99,7 @@
(markdown-strip thought)))) (markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[))) (if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case (handler-case
(let ((parsed (read-from-string cleaned))) (let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed) (if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed))) (let ((normalized (plist-keywords-normalize parsed)))
;; Ensure explanation is present in the payload for policy gate ;; Ensure explanation is present in the payload for policy gate
@@ -283,3 +283,19 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(list :status :success :content "mock-response"))) (list :status :success :content "mock-response")))
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend)))) (let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
(is (string= "mock-response" result))))) (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::*backend-registry* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* '(:mock-evil)))
(setf (gethash :mock-evil passepartout::*backend-registry*)
(lambda (prompt sp &key model)
(declare (ignore prompt sp model))
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
(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))))

View File

@@ -140,7 +140,7 @@
(when (uiop:file-exists-p path) (when (uiop:file-exists-p path)
(handler-case (handler-case
(with-open-file (stream path :direction :input) (with-open-file (stream path :direction :input)
(let ((data (read stream nil))) (let ((data (let ((*read-eval* nil)) (read stream nil))))
(when data (when data
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store))) (let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
(setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist))) (setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist)))

View File

@@ -247,21 +247,38 @@ declarations so embedded test code evaluates in the correct package."
(log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*)) (log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
(with-input-from-string (s content) (with-input-from-string (s content)
(loop for form = (read s nil :eof) until (eq form :eof) (loop for form = (read s nil :eof) until (eq form :eof)
do (handler-case (eval form) do (handler-case (eval form)
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c)))))) (error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
(let ((target-pkg (find-package :passepartout)) (let* ((jailed-pkg (find-package pkg-name))
(exported 0) (restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND"))
(seen (make-hash-table :test 'equal))) (violation (loop for r in restricted
(do-symbols (sym (find-package pkg-name)) for sym = (find-symbol r :uiop)
(when (and (eq (symbol-package sym) (find-package pkg-name)) when (and sym (fboundp sym)
(or (fboundp sym) (boundp sym)) (loop for skill-sym being the symbols of jailed-pkg
(not (gethash (symbol-name sym) seen))) when (and (fboundp skill-sym)
(setf (gethash (symbol-name sym) seen) t) (eq (symbol-function skill-sym)
(incf exported) (symbol-function sym)))
(let ((existing (find-symbol (symbol-name sym) target-pkg))) return skill-sym))
(when existing (unintern existing target-pkg))) collect (format nil "~a" sym))))
(import sym target-pkg) (when violation
(ignore-errors (export sym target-pkg)))) (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" (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
exported (package-name (find-package pkg-name)))) exported (package-name (find-package pkg-name))))
(setf (skill-entry-status entry) :ready)) (setf (skill-entry-status entry) :ready))

View File

@@ -88,14 +88,31 @@
(progn (funcall 'unfocus) (progn (funcall 'unfocus)
(add-msg :system "Popped context")) (add-msg :system "Popped context"))
(add-msg :system "Context manager not loaded"))) (add-msg :system "Context manager not loaded")))
;; Normal message ;; /quit — save history and exit
((or (string-equal text "/quit") (string-equal text "/q"))
(let ((hist-file (merge-pathnames ".cache/passepartout/history"
(user-homedir-pathname))))
(uiop:ensure-all-directories-exist (list hist-file))
(with-open-file (out hist-file :direction :output
:if-exists :supersede :if-does-not-exist :create)
(dolist (entry (reverse (st :input-history)))
(write-line entry out))))
(add-msg :system "* Goodbye *")
(send-daemon (list :type :event :payload '(:action :quit)))
(setf (st :running) nil))
;; /reconnect — re-establish daemon connection
((string-equal text "/reconnect")
(disconnect-daemon)
(connect-daemon))
;; Normal message
(t (t
(add-msg :user text) (add-msg :user text)
(setf (st :busy) t) (setf (st :busy) t)
(send-daemon (list :type :event (send-daemon (list :type :event
:payload (list :sensor :user-input :text text))))) :payload (list :sensor :user-input :text text)))))
(setf (st :input-buffer) nil) (setf (st :input-buffer) nil)
(setf (st :dirty) (list t t t)))))) (setf (st :cursor-pos) 0)
(setf (st :dirty) (list t t t))))))
;; Tab — command completion ;; Tab — command completion
((or (eql ch 9) (eq ch :tab)) ((or (eql ch 9) (eq ch :tab))
(let ((text (input-string))) (let ((text (input-string)))
@@ -110,46 +127,57 @@
(when (member match '("/eval" "/focus" "/scope") :test #'string=) (when (member match '("/eval" "/focus" "/scope") :test #'string=)
(push #\Space (st :input-buffer))) (push #\Space (st :input-buffer)))
(setf (st :dirty) (list nil nil t))))))) (setf (st :dirty) (list nil nil t)))))))
;; Backspace ;; Backspace
((or (eq ch :backspace) (eql ch 127) (eql ch 8) ((or (eq ch :backspace) (eql ch 127) (eql ch 8)
(eql ch #\Backspace)) (eql ch #\Backspace))
(when (st :input-buffer) (pop (st :input-buffer))) (input-delete-char)
(setf (st :dirty) (list nil nil t))) (setf (st :dirty) (list nil nil t)))
;; Left arrow
((or (eq ch :left) (eql ch 260))
(when (> (or (st :cursor-pos) 0) 0)
(decf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Right arrow
((or (eq ch :right) (eql ch 261))
(when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
(incf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Up arrow ;; Up arrow
((or (eq ch :up) (eql ch 259)) ((or (eq ch :up) (eql ch 259))
(let* ((h (st :input-history)) (p (st :input-hpos))) (let* ((h (st :input-history)) (p (st :input-hpos)))
(when (and h (< p (1- (length h)))) (when (and h (< p (1- (length h))))
(incf (st :input-hpos)) (incf (st :input-hpos))
(setf (st :input-buffer) (setf (st :input-buffer)
(reverse (coerce (nth (st :input-hpos) h) 'list))) (reverse (coerce (nth (st :input-hpos) h) 'list)))
(setf (st :dirty) (list nil nil t))))) (setf (st :dirty) (list nil nil t)))))
;; Down arrow ;; Down arrow
((or (eq ch :down) (eql ch 258)) ((or (eq ch :down) (eql ch 258))
(when (> (st :input-hpos) 0) (when (> (st :input-hpos) 0)
(decf (st :input-hpos)) (decf (st :input-hpos))
(let ((h (st :input-history))) (let ((h (st :input-history)))
(setf (st :input-buffer) (setf (st :input-buffer)
(if (and h (< (st :input-hpos) (length h))) (if (and h (< (st :input-hpos) (length h)))
(reverse (coerce (nth (st :input-hpos) h) 'list)) (reverse (coerce (nth (st :input-hpos) h) 'list))
nil)) nil))
(setf (st :dirty) (list nil nil t))))) (setf (st :dirty) (list nil nil t)))))
;; PageUp ;; PageUp
((or (eq ch :ppage) (eql ch 339)) ((or (eq ch :ppage) (eql ch 339))
(incf (st :scroll-offset) 5) (let ((max-offset (max 0 (- (length (st :messages)) 1))))
(setf (st :dirty) (list nil t nil))) (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 5))))
;; PageDown (setf (st :dirty) (list nil t nil)))
((or (eq ch :npage) (eql ch 338)) ;; PageDown
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5))) ((or (eq ch :npage) (eql ch 338))
(setf (st :dirty) (list nil t nil))) (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
;; Printable (setf (st :dirty) (list nil t nil)))
(t ;; Printable
(let ((chr (typecase ch (t
(character ch) (let ((chr (typecase ch
(integer (code-char ch)) (character ch)
(t nil)))) (integer (code-char ch))
(when (and chr (graphic-char-p chr)) (t nil))))
(push chr (st :input-buffer)) (when (and chr (graphic-char-p chr))
(setf (st :dirty) (list nil nil t)))))))) (input-insert-char chr)
(setf (st :dirty) (list nil nil t))))))))
(defun on-daemon-msg (msg) (defun on-daemon-msg (msg)
(let* ((payload (getf msg :payload)) (let* ((payload (getf msg :payload))
@@ -190,11 +218,28 @@
(error () nil))) (error () nil)))
(defun reader-loop (s) (defun reader-loop (s)
(loop while (and (st :running) (open-stream-p s)) (let ((consecutive-nils 0))
do (let ((msg (recv-daemon s))) (loop while (and (st :running) (open-stream-p s))
(if msg do (let ((msg (recv-daemon s)))
(queue-event (list :type :daemon :payload msg)) (if msg
(sleep 0.5))))) (progn (queue-event (list :type :daemon :payload msg))
(setf consecutive-nils 0))
(progn (sleep 0.5)
(incf consecutive-nils)
(when (> consecutive-nils 10)
(queue-event (list :type :disconnected))
(return))))))))
(defun load-history ()
"Load input history from disk on TUI startup."
(let ((hist-file (merge-pathnames ".cache/passepartout/history"
(user-homedir-pathname))))
(when (uiop:file-exists-p hist-file)
(with-open-file (in hist-file :direction :input)
(loop for line = (read-line in nil nil)
while line
do (push line (st :input-history))))
(setf (st :input-history) (nreverse (st :input-history))))))
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105)) (defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
(add-msg :system "* Connecting to daemon... *") (add-msg :system "* Connecting to daemon... *")
@@ -228,6 +273,7 @@
(defun tui-main () (defun tui-main ()
(init-state) (init-state)
(load-history)
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
(let* ((h (or (height scr) 24)) (let* ((h (or (height scr) 24))
(w (or (width scr) 80)) (w (or (width scr) 80))
@@ -240,7 +286,9 @@
4006))) 4006)))
(setf (function-keys-enabled-p iw) t (setf (function-keys-enabled-p iw) t
(input-blocking iw) nil (input-blocking iw) nil
(st :dirty) (list t t t)) (st :dirty) (list t t t)
;; Store windows in state for SIGWINCH handler
(st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw)
(connect-daemon) (connect-daemon)
(when (> swank-port 0) (when (> swank-port 0)
(handler-case (handler-case
@@ -258,11 +306,34 @@
(refresh scr) (refresh scr)
(loop while (st :running) do (loop while (st :running) do
(dolist (ev (drain-queue)) (dolist (ev (drain-queue))
(when (eq (getf ev :type) :daemon) (cond
(on-daemon-msg (getf ev :payload)))) ((eq (getf ev :type) :daemon)
(on-daemon-msg (getf ev :payload)))
((eq (getf ev :type) :disconnected)
(setf (st :connected) nil
(st :busy) nil)
(add-msg :system "* Connection lost — type /reconnect to retry *"))))
(let ((ch (get-char iw))) (let ((ch (get-char iw)))
(when (and ch (not (equal ch -1))) (cond
(on-key ch))) ((or (not ch) (equal ch -1)) nil)
;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses)
((eql ch 410)
(let* ((new-h (or (height scr) 24))
(new-w (or (width scr) 80))
(new-ch (- new-h 5)))
(setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1)
ch new-ch
cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1)
iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1)
w new-w
h new-h)
(setf (function-keys-enabled-p iw) t
(input-blocking iw) nil
(st :dirty) (list t t t)
(st :sw) sw (st :cw) cw (st :iw) iw)
(redraw sw cw ch iw)
(refresh scr)))
(t (on-key ch))))
(redraw sw cw ch iw) (redraw sw cw ch iw)
(refresh scr) (refresh scr)
(sleep 0.03)) (sleep 0.03))

View File

@@ -28,7 +28,8 @@
(setf *state* (setf *state*
(list :running t :mode :chat :connected nil :stream nil (list :running t :mode :chat :connected nil :stream nil
:input-buffer nil :input-history nil :input-hpos 0 :input-buffer nil :input-history nil :input-hpos 0
:messages nil :scroll-offset 0 :busy nil :messages (make-array 16 :adjustable t :fill-pointer 0)
:scroll-offset 0 :busy nil :cursor-pos 0
:dirty (list nil nil nil)))) :dirty (list nil nil nil))))
(defun now () (defun now ()
@@ -39,8 +40,27 @@
(defun input-string () (defun input-string ()
(coerce (reverse (st :input-buffer)) '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) (defun add-msg (role content)
(push (list :role role :content content :time (now)) (st :messages)) (vector-push-extend (list :role role :content content :time (now)) (st :messages))
(setf (st :dirty) (list t t nil))) (setf (st :dirty) (list t t nil)))
(defun queue-event (ev) (defun queue-event (ev)

View File

@@ -14,42 +14,84 @@
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp)) (add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp))
(refresh win)) (refresh win))
(defun word-wrap (text width)
"Break text into lines at word boundaries, each <= width chars.
Returns list of trimmed strings. Single words wider than width are split."
(let ((lines '())
(pos 0)
(len (length text)))
(loop while (< pos len)
do (let ((end (min len (+ pos width))))
(cond
((>= end len)
(push (string-trim '(#\Space) (subseq text pos len)) lines)
(setf pos len))
((char= (char text (1- end)) #\Space)
(push (string-trim '(#\Space) (subseq text pos end)) lines)
(setf pos end))
(t
(let ((last-space (position #\Space text :from-end t :end (1+ end) :start pos)))
(if (and last-space (> last-space pos))
(progn
(push (string-trim '(#\Space) (subseq text pos last-space)) lines)
(setf pos (1+ last-space)))
(progn
(push (string-trim '(#\Space) (subseq text pos end)) lines)
(setf pos end))))))))
(nreverse lines)))
(defun view-chat (win h) (defun view-chat (win h)
(clear win) (clear win)
(box win 0 0) (box win 0 0)
(let* ((w (or (width win) 78)) (let* ((w (or (width win) 78))
(msgs (reverse (st :messages))) (msgs (st :messages))
(max-lines (- h 2))
(total (length msgs)) (total (length msgs))
(start (max 0 (- total max-lines (st :scroll-offset)))) (max-lines (- h 2))
(y 1)) (y 1))
(loop for i from start below total ;; Count visible messages from end, accounting for word wrap
while (< y (1- h)) (let* ((msg-count 0)
do (let ((msg (nth i msgs))) (lines-remaining max-lines))
(let* ((role (getf msg :role)) (loop for i from (1- total) downto 0
while (> lines-remaining 0)
do (let* ((msg (aref msgs i))
(role (getf msg :role))
(content (getf msg :content)) (content (getf msg :content))
(time (or (getf msg :time) "")) (time (or (getf msg :time) ""))
(label (case role (prefix (case role (:user "⬆") (:agent "⬇") (t " ")))
(:user (format nil " [~a] ~a" time content)) (line-text (format nil "~a [~a] ~a" prefix time content))
(:agent (format nil "⬇ [~a] ~a" time content)) (wrapped (word-wrap line-text (- w 2)))
(:system (format nil " [~a] ~a" time content)) (nlines (length wrapped)))
(t (format nil " [~a] ~a" time content)))) (if (<= nlines lines-remaining)
(color (theme-color (case role (progn (decf lines-remaining nlines) (incf msg-count))
(:user :user) (setf lines-remaining 0))))
(:agent :agent) ;; Render from the correct starting message
(:system :system) (let* ((scroll-skip (st :scroll-offset))
(t :agent))))) (start (max 0 (- total msg-count scroll-skip))))
(add-string win label :y y :x 1 :n (1- w) :fgcolor color) (loop for i from start below total
(incf y))))) while (< y (1- h))
do (let* ((msg (aref msgs i))
(role (getf msg :role))
(content (getf msg :content))
(time (or (getf msg :time) ""))
(color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent))))
(prefix (case role (:user "⬆") (:agent "⬇") (t " ")))
(line-text (format nil "~a [~a] ~a" prefix time content))
(wrapped (word-wrap line-text (- w 2))))
(dolist (line wrapped)
(when (< y (1- h))
(add-string win line :y y :x 1 :n (1- w) :fgcolor color)
(incf y))))))))
(refresh win)) (refresh win))
(defun view-input (win) (defun view-input (win)
(let* ((text (input-string)) (let* ((text (input-string))
(w (or (width win) 78)) (w (or (width win) 78))
(clip (min (length text) (1- w)))) (pos (or (st :cursor-pos) 0))
(display-start (max 0 (- pos (1- w))))
(visible (subseq text display-start (min (length text) (+ display-start w)))))
(clear win) (clear win)
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input)) (add-string win (format nil "~a " visible) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input))
(setf (cursor-position win) (list 0 clip))) (setf (cursor-position win) (list 0 (min (- pos display-start) (1- w)))))
(refresh win)) (refresh win))
(defun redraw (sw cw ch iw) (defun redraw (sw cw ch iw)

View File

@@ -278,7 +278,8 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
;; Vector 8: High-impact action approval ;; Vector 8: High-impact action approval
((or (member target '(:shell)) ((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) (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 :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)) (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
(list :type :EVENT :payload (list :sensor :approval-required :action action))) (list :type :EVENT :payload (list :sensor :approval-required :action action)))
(t action)))) (t action))))

View File

@@ -1,16 +1,15 @@
(defun actuator-shell-execute (action context) (defun actuator-shell-execute (action context)
"Executes a bash command with timeout (via timeout(1)) and output limit." "Executes a shell command via the OS timeout binary with output limit."
(declare (ignore context)) (declare (ignore context))
(let* ((payload (getf action :payload)) (let* ((payload (getf action :payload))
(cmd (getf payload :cmd)) (cmd (getf payload :cmd))
(timeout-sym (find-symbol "*BOUNCER-SHELL-TIMEOUT*" :passepartout)) (timeout-sym (find-symbol "*BOUNCER-SHELL-TIMEOUT*" :passepartout))
(timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30))) (timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30)))
(max-sym (find-symbol "*BOUNCER-SHELL-MAX-OUTPUT*" :passepartout)) (max-sym (find-symbol "*BOUNCER-SHELL-MAX-OUTPUT*" :passepartout))
(max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))) (max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))))
(wrapped-cmd (format nil "timeout ~a bash -c ~s" timeout cmd)))
(log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout) (log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout)
(multiple-value-bind (out err code) (multiple-value-bind (out err code)
(uiop:run-program (list "bash" "-c" wrapped-cmd) (uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)
:output :string :error-output :string :output :string :error-output :string
:ignore-error-status t) :ignore-error-status t)
(cond (cond

View File

@@ -135,7 +135,7 @@ Handles internal harness commands: ~:eval~ (execute arbitrary Lisp) and ~:messag
(cmd (getf payload :action))) (cmd (getf payload :action)))
(case cmd (case cmd
(:eval (:eval
(eval (read-from-string (getf payload :code)))) (eval (let ((*read-eval* nil)) (read-from-string (getf payload :code)))))
(:message (:message
(log-message "ACT [System]: ~a" (getf payload :text))) (log-message "ACT [System]: ~a" (getf payload :text)))
(t (t

View File

@@ -235,7 +235,7 @@ The system prompt assembly order — identity, tools, context, logs, mandates
(markdown-strip thought)))) (markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[))) (if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case (handler-case
(let ((parsed (read-from-string cleaned))) (let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed) (if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed))) (let ((normalized (plist-keywords-normalize parsed)))
;; Ensure explanation is present in the payload for policy gate ;; Ensure explanation is present in the payload for policy gate
@@ -460,4 +460,20 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
(list :status :success :content "mock-response"))) (list :status :success :content "mock-response")))
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend)))) (let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
(is (string= "mock-response" result))))) (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::*backend-registry* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* '(:mock-evil)))
(setf (gethash :mock-evil passepartout::*backend-registry*)
(lambda (prompt sp &key model)
(declare (ignore prompt sp model))
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
(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))))
#+end_src #+end_src

View File

@@ -349,7 +349,7 @@ Restores memory state from a previously saved snapshot file. Called during boot
(when (uiop:file-exists-p path) (when (uiop:file-exists-p path)
(handler-case (handler-case
(with-open-file (stream path :direction :input) (with-open-file (stream path :direction :input)
(let ((data (read stream nil))) (let ((data (let ((*read-eval* nil)) (read stream nil))))
(when data (when data
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store))) (let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
(setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist))) (setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist)))

View File

@@ -372,21 +372,38 @@ The same jailed package and symbol export process applies.
(log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*)) (log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
(with-input-from-string (s content) (with-input-from-string (s content)
(loop for form = (read s nil :eof) until (eq form :eof) (loop for form = (read s nil :eof) until (eq form :eof)
do (handler-case (eval form) do (handler-case (eval form)
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c)))))) (error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
(let ((target-pkg (find-package :passepartout)) (let* ((jailed-pkg (find-package pkg-name))
(exported 0) (restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND"))
(seen (make-hash-table :test 'equal))) (violation (loop for r in restricted
(do-symbols (sym (find-package pkg-name)) for sym = (find-symbol r :uiop)
(when (and (eq (symbol-package sym) (find-package pkg-name)) when (and sym (fboundp sym)
(or (fboundp sym) (boundp sym)) (loop for skill-sym being the symbols of jailed-pkg
(not (gethash (symbol-name sym) seen))) when (and (fboundp skill-sym)
(setf (gethash (symbol-name sym) seen) t) (eq (symbol-function skill-sym)
(incf exported) (symbol-function sym)))
(let ((existing (find-symbol (symbol-name sym) target-pkg))) return skill-sym))
(when existing (unintern existing target-pkg))) collect (format nil "~a" sym))))
(import sym target-pkg) (when violation
(ignore-errors (export sym target-pkg)))) (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" (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
exported (package-name (find-package pkg-name)))) exported (package-name (find-package pkg-name))))
(setf (skill-entry-status entry) :ready)) (setf (skill-entry-status entry) :ready))

View File

@@ -116,14 +116,31 @@ Event handlers + daemon I/O + main loop.
(progn (funcall 'unfocus) (progn (funcall 'unfocus)
(add-msg :system "Popped context")) (add-msg :system "Popped context"))
(add-msg :system "Context manager not loaded"))) (add-msg :system "Context manager not loaded")))
;; Normal message ;; /quit — save history and exit
((or (string-equal text "/quit") (string-equal text "/q"))
(let ((hist-file (merge-pathnames ".cache/passepartout/history"
(user-homedir-pathname))))
(uiop:ensure-all-directories-exist (list hist-file))
(with-open-file (out hist-file :direction :output
:if-exists :supersede :if-does-not-exist :create)
(dolist (entry (reverse (st :input-history)))
(write-line entry out))))
(add-msg :system "* Goodbye *")
(send-daemon (list :type :event :payload '(:action :quit)))
(setf (st :running) nil))
;; /reconnect — re-establish daemon connection
((string-equal text "/reconnect")
(disconnect-daemon)
(connect-daemon))
;; Normal message
(t (t
(add-msg :user text) (add-msg :user text)
(setf (st :busy) t) (setf (st :busy) t)
(send-daemon (list :type :event (send-daemon (list :type :event
:payload (list :sensor :user-input :text text))))) :payload (list :sensor :user-input :text text)))))
(setf (st :input-buffer) nil) (setf (st :input-buffer) nil)
(setf (st :dirty) (list t t t)))))) (setf (st :cursor-pos) 0)
(setf (st :dirty) (list t t t))))))
;; Tab — command completion ;; Tab — command completion
((or (eql ch 9) (eq ch :tab)) ((or (eql ch 9) (eq ch :tab))
(let ((text (input-string))) (let ((text (input-string)))
@@ -138,46 +155,57 @@ Event handlers + daemon I/O + main loop.
(when (member match '("/eval" "/focus" "/scope") :test #'string=) (when (member match '("/eval" "/focus" "/scope") :test #'string=)
(push #\Space (st :input-buffer))) (push #\Space (st :input-buffer)))
(setf (st :dirty) (list nil nil t))))))) (setf (st :dirty) (list nil nil t)))))))
;; Backspace ;; Backspace
((or (eq ch :backspace) (eql ch 127) (eql ch 8) ((or (eq ch :backspace) (eql ch 127) (eql ch 8)
(eql ch #\Backspace)) (eql ch #\Backspace))
(when (st :input-buffer) (pop (st :input-buffer))) (input-delete-char)
(setf (st :dirty) (list nil nil t))) (setf (st :dirty) (list nil nil t)))
;; Left arrow
((or (eq ch :left) (eql ch 260))
(when (> (or (st :cursor-pos) 0) 0)
(decf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Right arrow
((or (eq ch :right) (eql ch 261))
(when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
(incf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Up arrow ;; Up arrow
((or (eq ch :up) (eql ch 259)) ((or (eq ch :up) (eql ch 259))
(let* ((h (st :input-history)) (p (st :input-hpos))) (let* ((h (st :input-history)) (p (st :input-hpos)))
(when (and h (< p (1- (length h)))) (when (and h (< p (1- (length h))))
(incf (st :input-hpos)) (incf (st :input-hpos))
(setf (st :input-buffer) (setf (st :input-buffer)
(reverse (coerce (nth (st :input-hpos) h) 'list))) (reverse (coerce (nth (st :input-hpos) h) 'list)))
(setf (st :dirty) (list nil nil t))))) (setf (st :dirty) (list nil nil t)))))
;; Down arrow ;; Down arrow
((or (eq ch :down) (eql ch 258)) ((or (eq ch :down) (eql ch 258))
(when (> (st :input-hpos) 0) (when (> (st :input-hpos) 0)
(decf (st :input-hpos)) (decf (st :input-hpos))
(let ((h (st :input-history))) (let ((h (st :input-history)))
(setf (st :input-buffer) (setf (st :input-buffer)
(if (and h (< (st :input-hpos) (length h))) (if (and h (< (st :input-hpos) (length h)))
(reverse (coerce (nth (st :input-hpos) h) 'list)) (reverse (coerce (nth (st :input-hpos) h) 'list))
nil)) nil))
(setf (st :dirty) (list nil nil t))))) (setf (st :dirty) (list nil nil t)))))
;; PageUp ;; PageUp
((or (eq ch :ppage) (eql ch 339)) ((or (eq ch :ppage) (eql ch 339))
(incf (st :scroll-offset) 5) (let ((max-offset (max 0 (- (length (st :messages)) 1))))
(setf (st :dirty) (list nil t nil))) (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 5))))
;; PageDown (setf (st :dirty) (list nil t nil)))
((or (eq ch :npage) (eql ch 338)) ;; PageDown
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5))) ((or (eq ch :npage) (eql ch 338))
(setf (st :dirty) (list nil t nil))) (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
;; Printable (setf (st :dirty) (list nil t nil)))
(t ;; Printable
(let ((chr (typecase ch (t
(character ch) (let ((chr (typecase ch
(integer (code-char ch)) (character ch)
(t nil)))) (integer (code-char ch))
(when (and chr (graphic-char-p chr)) (t nil))))
(push chr (st :input-buffer)) (when (and chr (graphic-char-p chr))
(setf (st :dirty) (list nil nil t)))))))) (input-insert-char chr)
(setf (st :dirty) (list nil nil t))))))))
(defun on-daemon-msg (msg) (defun on-daemon-msg (msg)
(let* ((payload (getf msg :payload)) (let* ((payload (getf msg :payload))
@@ -221,11 +249,28 @@ Event handlers + daemon I/O + main loop.
(error () nil))) (error () nil)))
(defun reader-loop (s) (defun reader-loop (s)
(loop while (and (st :running) (open-stream-p s)) (let ((consecutive-nils 0))
do (let ((msg (recv-daemon s))) (loop while (and (st :running) (open-stream-p s))
(if msg do (let ((msg (recv-daemon s)))
(queue-event (list :type :daemon :payload msg)) (if msg
(sleep 0.5))))) (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))))))
#+end_src #+end_src
** Connection ** Connection
@@ -265,6 +310,7 @@ Event handlers + daemon I/O + main loop.
#+begin_src lisp #+begin_src lisp
(defun tui-main () (defun tui-main ()
(init-state) (init-state)
(load-history)
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
(let* ((h (or (height scr) 24)) (let* ((h (or (height scr) 24))
(w (or (width scr) 80)) (w (or (width scr) 80))
@@ -277,7 +323,9 @@ Event handlers + daemon I/O + main loop.
4006))) 4006)))
(setf (function-keys-enabled-p iw) t (setf (function-keys-enabled-p iw) t
(input-blocking iw) nil (input-blocking iw) nil
(st :dirty) (list t t t)) (st :dirty) (list t t t)
;; Store windows in state for SIGWINCH handler
(st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw)
(connect-daemon) (connect-daemon)
(when (> swank-port 0) (when (> swank-port 0)
(handler-case (handler-case
@@ -295,11 +343,34 @@ Event handlers + daemon I/O + main loop.
(refresh scr) (refresh scr)
(loop while (st :running) do (loop while (st :running) do
(dolist (ev (drain-queue)) (dolist (ev (drain-queue))
(when (eq (getf ev :type) :daemon) (cond
(on-daemon-msg (getf ev :payload)))) ((eq (getf ev :type) :daemon)
(on-daemon-msg (getf ev :payload)))
((eq (getf ev :type) :disconnected)
(setf (st :connected) nil
(st :busy) nil)
(add-msg :system "* Connection lost — type /reconnect to retry *"))))
(let ((ch (get-char iw))) (let ((ch (get-char iw)))
(when (and ch (not (equal ch -1))) (cond
(on-key ch))) ((or (not ch) (equal ch -1)) nil)
;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses)
((eql ch 410)
(let* ((new-h (or (height scr) 24))
(new-w (or (width scr) 80))
(new-ch (- new-h 5)))
(setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1)
ch new-ch
cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1)
iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1)
w new-w
h new-h)
(setf (function-keys-enabled-p iw) t
(input-blocking iw) nil
(st :dirty) (list t t t)
(st :sw) sw (st :cw) cw (st :iw) iw)
(redraw sw cw ch iw)
(refresh scr)))
(t (on-key ch))))
(redraw sw cw ch iw) (redraw sw cw ch iw)
(refresh scr) (refresh scr)
(sleep 0.03)) (sleep 0.03))

View File

@@ -48,7 +48,8 @@ All state mutation flows through event handlers in the controller.
(setf *state* (setf *state*
(list :running t :mode :chat :connected nil :stream nil (list :running t :mode :chat :connected nil :stream nil
:input-buffer nil :input-history nil :input-hpos 0 :input-buffer nil :input-history nil :input-hpos 0
:messages nil :scroll-offset 0 :busy nil :messages (make-array 16 :adjustable t :fill-pointer 0)
:scroll-offset 0 :busy nil :cursor-pos 0
:dirty (list nil nil nil)))) :dirty (list nil nil nil))))
#+end_src #+end_src
@@ -62,8 +63,27 @@ All state mutation flows through event handlers in the controller.
(defun input-string () (defun input-string ()
(coerce (reverse (st :input-buffer)) '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) (defun add-msg (role content)
(push (list :role role :content content :time (now)) (st :messages)) (vector-push-extend (list :role role :content content :time (now)) (st :messages))
(setf (st :dirty) (list t t nil))) (setf (st :dirty) (list t t nil)))
#+end_src #+end_src

View File

@@ -39,33 +39,73 @@ State is read via ~(st :key)~ — no mutation here.
** Chat Area ** Chat Area
#+begin_src lisp #+begin_src lisp
(defun word-wrap (text width)
"Break text into lines at word boundaries, each <= width chars.
Returns list of trimmed strings. Single words wider than width are split."
(let ((lines '())
(pos 0)
(len (length text)))
(loop while (< pos len)
do (let ((end (min len (+ pos width))))
(cond
((>= end len)
(push (string-trim '(#\Space) (subseq text pos len)) lines)
(setf pos len))
((char= (char text (1- end)) #\Space)
(push (string-trim '(#\Space) (subseq text pos end)) lines)
(setf pos end))
(t
(let ((last-space (position #\Space text :from-end t :end (1+ end) :start pos)))
(if (and last-space (> last-space pos))
(progn
(push (string-trim '(#\Space) (subseq text pos last-space)) lines)
(setf pos (1+ last-space)))
(progn
(push (string-trim '(#\Space) (subseq text pos end)) lines)
(setf pos end))))))))
(nreverse lines)))
(defun view-chat (win h) (defun view-chat (win h)
(clear win) (clear win)
(box win 0 0) (box win 0 0)
(let* ((w (or (width win) 78)) (let* ((w (or (width win) 78))
(msgs (reverse (st :messages))) (msgs (st :messages))
(max-lines (- h 2))
(total (length msgs)) (total (length msgs))
(start (max 0 (- total max-lines (st :scroll-offset)))) (max-lines (- h 2))
(y 1)) (y 1))
(loop for i from start below total ;; Count visible messages from end, accounting for word wrap
while (< y (1- h)) (let* ((msg-count 0)
do (let ((msg (nth i msgs))) (lines-remaining max-lines))
(let* ((role (getf msg :role)) (loop for i from (1- total) downto 0
while (> lines-remaining 0)
do (let* ((msg (aref msgs i))
(role (getf msg :role))
(content (getf msg :content)) (content (getf msg :content))
(time (or (getf msg :time) "")) (time (or (getf msg :time) ""))
(label (case role (prefix (case role (:user "⬆") (:agent "⬇") (t " ")))
(:user (format nil " [~a] ~a" time content)) (line-text (format nil "~a [~a] ~a" prefix time content))
(:agent (format nil "⬇ [~a] ~a" time content)) (wrapped (word-wrap line-text (- w 2)))
(:system (format nil " [~a] ~a" time content)) (nlines (length wrapped)))
(t (format nil " [~a] ~a" time content)))) (if (<= nlines lines-remaining)
(color (theme-color (case role (progn (decf lines-remaining nlines) (incf msg-count))
(:user :user) (setf lines-remaining 0))))
(:agent :agent) ;; Render from the correct starting message
(:system :system) (let* ((scroll-skip (st :scroll-offset))
(t :agent))))) (start (max 0 (- total msg-count scroll-skip))))
(add-string win label :y y :x 1 :n (1- w) :fgcolor color) (loop for i from start below total
(incf y))))) while (< y (1- h))
do (let* ((msg (aref msgs i))
(role (getf msg :role))
(content (getf msg :content))
(time (or (getf msg :time) ""))
(color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent))))
(prefix (case role (:user "⬆") (:agent "⬇") (t " ")))
(line-text (format nil "~a [~a] ~a" prefix time content))
(wrapped (word-wrap line-text (- w 2))))
(dolist (line wrapped)
(when (< y (1- h))
(add-string win line :y y :x 1 :n (1- w) :fgcolor color)
(incf y))))))))
(refresh win)) (refresh win))
#+end_src #+end_src
@@ -74,10 +114,12 @@ State is read via ~(st :key)~ — no mutation here.
(defun view-input (win) (defun view-input (win)
(let* ((text (input-string)) (let* ((text (input-string))
(w (or (width win) 78)) (w (or (width win) 78))
(clip (min (length text) (1- w)))) (pos (or (st :cursor-pos) 0))
(display-start (max 0 (- pos (1- w))))
(visible (subseq text display-start (min (length text) (+ display-start w)))))
(clear win) (clear win)
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input)) (add-string win (format nil "~a " visible) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input))
(setf (cursor-position win) (list 0 clip))) (setf (cursor-position win) (list 0 (min (- pos display-start) (1- w)))))
(refresh win)) (refresh win))
#+end_src #+end_src

View File

@@ -426,7 +426,8 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
;; Vector 8: High-impact action approval ;; Vector 8: High-impact action approval
((or (member target '(:shell)) ((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) (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 :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)) (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
(list :type :EVENT :payload (list :sensor :approval-required :action action))) (list :type :EVENT :payload (list :sensor :approval-required :action action)))
(t action)))) (t action))))

View File

@@ -20,18 +20,17 @@ Because shell execution is the highest-risk operation in the system, the Shell A
;; REPL-VERIFIED: 2026-05-03T13:00:00 ;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp #+begin_src lisp
(defun actuator-shell-execute (action context) (defun actuator-shell-execute (action context)
"Executes a bash command with timeout (via timeout(1)) and output limit." "Executes a shell command via the OS timeout binary with output limit."
(declare (ignore context)) (declare (ignore context))
(let* ((payload (getf action :payload)) (let* ((payload (getf action :payload))
(cmd (getf payload :cmd)) (cmd (getf payload :cmd))
(timeout-sym (find-symbol "*BOUNCER-SHELL-TIMEOUT*" :passepartout)) (timeout-sym (find-symbol "*BOUNCER-SHELL-TIMEOUT*" :passepartout))
(timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30))) (timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30)))
(max-sym (find-symbol "*BOUNCER-SHELL-MAX-OUTPUT*" :passepartout)) (max-sym (find-symbol "*BOUNCER-SHELL-MAX-OUTPUT*" :passepartout))
(max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))) (max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))))
(wrapped-cmd (format nil "timeout ~a bash -c ~s" timeout cmd)))
(log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout) (log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout)
(multiple-value-bind (out err code) (multiple-value-bind (out err code)
(uiop:run-program (list "bash" "-c" wrapped-cmd) (uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)
:output :string :error-output :string :output :string :error-output :string
:ignore-error-status t) :ignore-error-status t)
(cond (cond