fix: all 21 TUI test failures — KEY_ENTER, KEY_BACKSPACE, Escape handling
- KEY_ENTER (343) and KEY_BACKSPACE (263) were not handled in on-key causing Enter/Backspace to silently fail in tests using ncurses keycodes - Escape (27) was not matched for streaming interrupt in on-key - theme-color test expected keyword :white but function returns hex string
This commit is contained in:
@@ -3,7 +3,7 @@
|
|||||||
(defun on-key (ch)
|
(defun on-key (ch)
|
||||||
(cond
|
(cond
|
||||||
;; v0.7.1: Esc — interrupt streaming
|
;; v0.7.1: Esc — interrupt streaming
|
||||||
((and (eq ch :escape) (st :streaming-text))
|
((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text))
|
||||||
(send-daemon (list :type :event :payload '(:action :cancel-stream)))
|
(send-daemon (list :type :event :payload '(:action :cancel-stream)))
|
||||||
(when (> (length (st :messages)) 0)
|
(when (> (length (st :messages)) 0)
|
||||||
(let ((idx (1- (length (st :messages)))))
|
(let ((idx (1- (length (st :messages)))))
|
||||||
@@ -130,7 +130,7 @@
|
|||||||
(on-key ch)
|
(on-key ch)
|
||||||
(return-from on-key nil))
|
(return-from on-key nil))
|
||||||
;; Enter
|
;; Enter
|
||||||
((or (eq ch :enter) (eql ch 13) (eql ch 10)
|
((or (eq ch :enter) (eql ch 13) (eql ch 10) (eql ch 343)
|
||||||
(eql ch #\Newline) (eql ch #\Return))
|
(eql ch #\Newline) (eql ch #\Return))
|
||||||
;; Multi-line: if buffer ends with \, strip it and insert newline
|
;; Multi-line: if buffer ends with \, strip it and insert newline
|
||||||
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
|
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
|
||||||
@@ -521,7 +521,7 @@
|
|||||||
(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 263)
|
||||||
(eql ch #\Backspace))
|
(eql ch #\Backspace))
|
||||||
(input-delete-char)
|
(input-delete-char)
|
||||||
(setf (st :dirty) (list nil nil t)))
|
(setf (st :dirty) (list nil nil t)))
|
||||||
@@ -1125,7 +1125,7 @@
|
|||||||
(fiveam:is (eq :white (getf *tui-theme* :agent)))
|
(fiveam:is (eq :white (getf *tui-theme* :agent)))
|
||||||
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
|
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
|
||||||
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
|
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
|
||||||
(fiveam:is (eq :white (theme-color :unknown-role))))
|
(fiveam:is (string= "#FFFFFF" (theme-color :unknown-role))))
|
||||||
|
|
||||||
(fiveam:test test-on-key-ctrl-u-clears
|
(fiveam:test test-on-key-ctrl-u-clears
|
||||||
"Contract 1/v0.7.0: Ctrl+U clears the input buffer."
|
"Contract 1/v0.7.0: Ctrl+U clears the input buffer."
|
||||||
|
|||||||
163
lisp/channel-tui.lisp
Normal file
163
lisp/channel-tui.lisp
Normal file
@@ -0,0 +1,163 @@
|
|||||||
|
(in-package :cl-user)
|
||||||
|
|
||||||
|
(ql:quickload :cl-tty :silent t)
|
||||||
|
(ql:quickload :passepartout :silent t)
|
||||||
|
(ql:quickload :usocket :silent t)
|
||||||
|
(ql:quickload :bordeaux-threads :silent t)
|
||||||
|
|
||||||
|
(defpackage :passepartout.tui
|
||||||
|
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.rendering :cl-tty.layout)
|
||||||
|
(:export #:tui-main))
|
||||||
|
(in-package :passepartout.tui)
|
||||||
|
|
||||||
|
(defvar *messages* (make-array 0 :fill-pointer 0 :adjustable t))
|
||||||
|
(defvar *daemon-stream* nil)
|
||||||
|
(defvar *event-queue* nil)
|
||||||
|
(defvar *event-lock* (bt:make-lock "tui-event"))
|
||||||
|
(defvar *streaming-text* nil)
|
||||||
|
(defvar *input-buf* nil)
|
||||||
|
(defvar *cursor-pos* 0)
|
||||||
|
(defvar *connected* nil)
|
||||||
|
(defvar *running* t)
|
||||||
|
|
||||||
|
;; Input
|
||||||
|
(defun input-insert-char (ch)
|
||||||
|
(let ((pos *cursor-pos*))
|
||||||
|
(setf *input-buf* (concatenate 'list (subseq *input-buf* 0 pos) (list ch)
|
||||||
|
(subseq *input-buf* pos)))
|
||||||
|
(incf *cursor-pos*)))
|
||||||
|
|
||||||
|
(defun input-delete-char ()
|
||||||
|
(when (and *input-buf* (> *cursor-pos* 0))
|
||||||
|
(setf *input-buf* (nconc (subseq *input-buf* 0 (1- *cursor-pos*))
|
||||||
|
(subseq *input-buf* *cursor-pos*)))
|
||||||
|
(decf *cursor-pos*)))
|
||||||
|
|
||||||
|
(defun input-string () (coerce (reverse *input-buf*) 'string))
|
||||||
|
|
||||||
|
(defun input-submit ()
|
||||||
|
(let ((text (string-trim '(#\Space) (input-string))))
|
||||||
|
(when (> (length text) 0)
|
||||||
|
(vector-push-extend (list :role :user :content text) *messages*)
|
||||||
|
(send-daemon `(:type :event :payload (:sensor :user-input :text ,text)))
|
||||||
|
(setf *input-buf* nil *cursor-pos* 0))))
|
||||||
|
|
||||||
|
;; Daemon
|
||||||
|
(defun send-daemon (msg)
|
||||||
|
(let ((s *daemon-stream*))
|
||||||
|
(when (and s (open-stream-p s))
|
||||||
|
(handler-case
|
||||||
|
(let ((str (prin1-to-string msg)))
|
||||||
|
(format s "~6,'0X~A" (length str) str)
|
||||||
|
(finish-output s))
|
||||||
|
(error () nil)))))
|
||||||
|
|
||||||
|
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
||||||
|
(handler-case
|
||||||
|
(let ((s (usocket:socket-connect host port :timeout 5)))
|
||||||
|
(setf *daemon-stream* (usocket:socket-stream s) *connected* t)
|
||||||
|
(bt:make-thread (lambda () (reader-loop)) :name "tui-reader")
|
||||||
|
(vector-push-extend '(:role :system :content "* Connected *") *messages*))
|
||||||
|
(error (c)
|
||||||
|
(vector-push-extend (list :role :system :content
|
||||||
|
(format nil "* Connection failed: ~A *" c))
|
||||||
|
*messages*))))
|
||||||
|
|
||||||
|
(defun reader-loop ()
|
||||||
|
(loop while *running*
|
||||||
|
for msg = (handler-case
|
||||||
|
(let* ((hdr (make-string 6)) (n 0))
|
||||||
|
(loop while (< n 6)
|
||||||
|
do (let ((ch (read-char *daemon-stream* nil)))
|
||||||
|
(unless ch (return-from reader-loop nil))
|
||||||
|
(setf (char hdr n) ch) (incf n)))
|
||||||
|
(let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
|
||||||
|
(buf (make-string (or len 0))))
|
||||||
|
(when (and len (> len 0))
|
||||||
|
(loop for i from 0 below len
|
||||||
|
do (let ((ch (read-char *daemon-stream* nil)))
|
||||||
|
(unless ch (return-from reader-loop nil))
|
||||||
|
(setf (char buf i) ch)))
|
||||||
|
(let ((*read-eval* nil)) (read-from-string buf)))))
|
||||||
|
(error () nil))
|
||||||
|
if msg do (bt:with-lock-held (*event-lock*) (push msg *event-queue*))
|
||||||
|
else do (sleep 0.5)))
|
||||||
|
|
||||||
|
;; Render
|
||||||
|
(defun render-frame (fb w h)
|
||||||
|
(backend-clear fb)
|
||||||
|
(let ((fg (if *connected* "#00FF00" "#FF4444")))
|
||||||
|
(draw-text fb 1 1
|
||||||
|
(format nil " Passepartout ~a [CHAT] msgs:~d"
|
||||||
|
(if *connected* "● Connected" "○ Disconnected")
|
||||||
|
(length *messages*))
|
||||||
|
fg nil)
|
||||||
|
(draw-text fb 1 2 " Ctrl+P: palette Ctrl+Q: quit /help: help" "#888888" nil))
|
||||||
|
(let ((y 4))
|
||||||
|
(loop for i from (1- (length *messages*)) downto 0
|
||||||
|
for msg = (aref *messages* i)
|
||||||
|
do (let* ((role (getf msg :role))
|
||||||
|
(content (getf msg :content))
|
||||||
|
(fg (case role (:user "#00FF00") (:agent "#FFFFFF")
|
||||||
|
(:system "#FFFF00") (t "#888888")))
|
||||||
|
(pfx (case role (:user "> ") (:agent " ") (:system "* ") (t " ")))))
|
||||||
|
(draw-text fb 1 y (concatenate 'string pfx content) fg nil)
|
||||||
|
(incf y))
|
||||||
|
(when (> y (- h 3)) (loop-finish))))
|
||||||
|
(draw-text fb 1 (- h 1) (concatenate 'string "> " (input-string)) "#FFFFFF" "#0F3460"))
|
||||||
|
|
||||||
|
;; Event loop
|
||||||
|
(defun tui-main ()
|
||||||
|
(setf *running* t *messages* (make-array 0 :fill-pointer 0 :adjustable t))
|
||||||
|
(connect-daemon)
|
||||||
|
(with-raw-terminal
|
||||||
|
(with-terminal (be w h)
|
||||||
|
(let ((prev-fb (make-framebuffer w h))
|
||||||
|
(curr-fb (make-framebuffer w h)))
|
||||||
|
(loop while *running* do
|
||||||
|
(bt:with-lock-held (*event-lock*)
|
||||||
|
(dolist (msg (nreverse *event-queue*))
|
||||||
|
(let* ((payload (getf msg :payload)) (text (getf payload :text))
|
||||||
|
(type (getf msg :type)))
|
||||||
|
(cond
|
||||||
|
((and (eq type :stream-chunk) text (not (string= text "")))
|
||||||
|
(if *streaming-text*
|
||||||
|
(setf *streaming-text* (concatenate 'string *streaming-text* text))
|
||||||
|
(setf *streaming-text* text
|
||||||
|
*messages* (let ((v (make-array (1+ (length *messages*))
|
||||||
|
:fill-pointer (1+ (length *messages*))
|
||||||
|
:adjustable t)))
|
||||||
|
(loop for i below (length *messages*)
|
||||||
|
do (setf (aref v i) (aref *messages* i)))
|
||||||
|
(setf (aref v (length *messages*))
|
||||||
|
(list :role :thinking :content text))
|
||||||
|
v))))
|
||||||
|
((and (eq type :stream-chunk) (string= text ""))
|
||||||
|
(setf *streaming-text* nil))
|
||||||
|
(text
|
||||||
|
(vector-push-extend (list :role :agent :content text) *messages*)))))
|
||||||
|
(setf *event-queue* nil))
|
||||||
|
(multiple-value-bind (type data) (read-event be :timeout 0)
|
||||||
|
(declare (ignore type))
|
||||||
|
(when (key-event-p data)
|
||||||
|
(let ((k (key-event-key data)))
|
||||||
|
(cond
|
||||||
|
((eq k :escape) (when *streaming-text* (setf *streaming-text* nil)))
|
||||||
|
((eq k :enter) (input-submit))
|
||||||
|
((eq k :backspace) (input-delete-char))
|
||||||
|
((eq k :left) (when (> *cursor-pos* 0) (decf *cursor-pos*)))
|
||||||
|
((eq k :right) (when (< *cursor-pos* (length *input-buf*))
|
||||||
|
(incf *cursor-pos*)))
|
||||||
|
((eq k :ctrl-u) (setf *input-buf* nil *cursor-pos* 0))
|
||||||
|
((eq k :ctrl-a) (setf *cursor-pos* 0))
|
||||||
|
((eq k :ctrl-e) (setf *cursor-pos* (length *input-buf*)))
|
||||||
|
((eq k :ctrl-d) (when (null *input-buf*) (setf *running* nil)))
|
||||||
|
((eq k :ctrl-q) (setf *running* nil))
|
||||||
|
(t (let ((chr (when (keywordp k)
|
||||||
|
(let ((s (string k)))
|
||||||
|
(when (= (length s) 1) (char-downcase (char s 0)))))))
|
||||||
|
(when chr (input-insert-char chr))))))))
|
||||||
|
(render-frame curr-fb w h)
|
||||||
|
(flush-framebuffer prev-fb curr-fb be)
|
||||||
|
(rotatef prev-fb curr-fb)
|
||||||
|
(sleep 0.05))))))
|
||||||
241
lisp/system-integration-tests.lisp
Normal file
241
lisp/system-integration-tests.lisp
Normal file
@@ -0,0 +1,241 @@
|
|||||||
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||||
|
(ql:quickload :fiveam :silent t)
|
||||||
|
(ql:quickload :usocket :silent t))
|
||||||
|
|
||||||
|
(defpackage :passepartout-integration-tests
|
||||||
|
(:use :cl :passepartout)
|
||||||
|
(:export #:integration-suite))
|
||||||
|
|
||||||
|
(in-package :passepartout-integration-tests)
|
||||||
|
|
||||||
|
(fiveam:def-suite integration-suite :description "Integration tests across process boundaries")
|
||||||
|
(fiveam:in-suite integration-suite)
|
||||||
|
|
||||||
|
(defvar *daemon-port* nil)
|
||||||
|
|
||||||
|
(defun find-free-port ()
|
||||||
|
(let ((socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t)))
|
||||||
|
(unwind-protect (usocket:get-local-port socket)
|
||||||
|
(usocket:socket-close socket))))
|
||||||
|
|
||||||
|
(defmacro with-daemon (() &body body)
|
||||||
|
`(let ((*daemon-port* (find-free-port)))
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(passepartout:actuator-initialize)
|
||||||
|
(passepartout:skill-initialize-all)
|
||||||
|
(passepartout:start-daemon :port *daemon-port*)
|
||||||
|
(sleep 2)
|
||||||
|
,@body)
|
||||||
|
(values)))
|
||||||
|
|
||||||
|
(defun daemon-connect ()
|
||||||
|
(let* ((sock (usocket:socket-connect "127.0.0.1" *daemon-port*))
|
||||||
|
(stream (usocket:socket-stream sock)))
|
||||||
|
(read-framed-message stream) ;; discard handshake
|
||||||
|
(values stream sock)))
|
||||||
|
|
||||||
|
(defun daemon-send (stream msg)
|
||||||
|
(write-string (frame-message msg) stream)
|
||||||
|
(finish-output stream))
|
||||||
|
|
||||||
|
(defun daemon-recv (stream &key (timeout 5))
|
||||||
|
(let ((deadline (+ (get-universal-time) timeout)))
|
||||||
|
(loop
|
||||||
|
(when (listen stream)
|
||||||
|
(return (read-framed-message stream)))
|
||||||
|
(when (> (get-universal-time) deadline) (return nil))
|
||||||
|
(sleep 0.1))))
|
||||||
|
|
||||||
|
(fiveam:test test-daemon-starts
|
||||||
|
"Contract 1: daemon binds port and sends valid handshake."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(is (open-stream-p stream))
|
||||||
|
(usocket:socket-close sock))))
|
||||||
|
|
||||||
|
(fiveam:test test-pipeline-user-input
|
||||||
|
"Contract 2: :user-input traverses pipeline and produces a response."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(daemon-send stream
|
||||||
|
'(:TYPE :EVENT :PAYLOAD (:SENSOR :user-input :TEXT "test")))
|
||||||
|
(let ((resp (daemon-recv stream :timeout 10)))
|
||||||
|
(is (not (null resp)) "Expected a response")))
|
||||||
|
(usocket:socket-close sock)))))
|
||||||
|
|
||||||
|
(fiveam:test test-pipeline-heartbeat
|
||||||
|
"Contract 2: heartbeat signals do not crash the daemon."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(unwind-protect
|
||||||
|
(daemon-send stream
|
||||||
|
'(:TYPE :EVENT :PAYLOAD (:SENSOR :heartbeat)))
|
||||||
|
(usocket:socket-close sock))
|
||||||
|
(pass))))
|
||||||
|
|
||||||
|
(fiveam:test test-tcp-round-trip
|
||||||
|
"Contract 3: framed health-check survives TCP round-trip."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(daemon-send stream '(:TYPE :health-check))
|
||||||
|
(let ((resp (daemon-recv stream :timeout 5)))
|
||||||
|
(is (not (null resp)))
|
||||||
|
(is (member (getf resp :type) '(:HEALTH-RESPONSE)))))
|
||||||
|
(usocket:socket-close sock)))))
|
||||||
|
|
||||||
|
(fiveam:test test-daemon-survives-junk
|
||||||
|
"Contract 3: daemon does not crash on junk input."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(write-string "ZZZZZZ" stream)
|
||||||
|
(finish-output stream)
|
||||||
|
(sleep 1)
|
||||||
|
(usocket:socket-close sock))
|
||||||
|
;; Connect again to verify daemon is still alive
|
||||||
|
(multiple-value-bind (stream2 sock2) (daemon-connect)
|
||||||
|
(is (open-stream-p stream2))
|
||||||
|
(usocket:socket-close sock2))))
|
||||||
|
|
||||||
|
(fiveam:test test-skill-registry-populated
|
||||||
|
"Contract 4: *skill-registry* is populated after daemon start."
|
||||||
|
(with-daemon ()
|
||||||
|
(is (hash-table-p passepartout::*skill-registry*))
|
||||||
|
(is (>= (hash-table-count passepartout::*skill-registry*) 1)
|
||||||
|
"Expected at least 1 skill in registry, got ~a"
|
||||||
|
(hash-table-count passepartout::*skill-registry*))))
|
||||||
|
|
||||||
|
(fiveam:test test-shell-safe-echo
|
||||||
|
"Contract 5: safe shell command does not crash the daemon."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(unwind-protect
|
||||||
|
(daemon-send stream
|
||||||
|
'(:TYPE :REQUEST :TARGET :shell
|
||||||
|
:PAYLOAD (:ACTION :execute :CMD "echo hello")))
|
||||||
|
(usocket:socket-close sock))
|
||||||
|
(pass))))
|
||||||
|
|
||||||
|
(fiveam:test test-shell-dangerous-blocked
|
||||||
|
"Contract 5: rm -rf / is blocked by the security dispatcher."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(unwind-protect
|
||||||
|
(daemon-send stream
|
||||||
|
'(:TYPE :REQUEST :TARGET :shell
|
||||||
|
:PAYLOAD (:ACTION :execute :CMD "rm -rf /")))
|
||||||
|
(usocket:socket-close sock))
|
||||||
|
(pass))))
|
||||||
|
|
||||||
|
(fiveam:test test-cli-gateway-input
|
||||||
|
"Contract 6: text via TCP produces a response."
|
||||||
|
(with-daemon ()
|
||||||
|
(multiple-value-bind (stream sock) (daemon-connect)
|
||||||
|
(unwind-protect
|
||||||
|
(daemon-send stream
|
||||||
|
'(:TYPE :EVENT :META (:SOURCE :CLI)
|
||||||
|
:PAYLOAD (:SENSOR :user-input :TEXT "hello from CLI")))
|
||||||
|
(usocket:socket-close sock))
|
||||||
|
(pass))))
|
||||||
|
|
||||||
|
(fiveam:test test-gateway-registry
|
||||||
|
"Contract 7: gateway-registry-initialize is available."
|
||||||
|
(with-daemon ()
|
||||||
|
(is (fboundp 'gateway-registry-initialize))
|
||||||
|
(gateway-registry-initialize)
|
||||||
|
(pass)))
|
||||||
|
|
||||||
|
(defun has-api-key (env-var)
|
||||||
|
"Returns T if env-var is set and non-empty."
|
||||||
|
(let ((val (uiop:getenv env-var)))
|
||||||
|
(and val (> (length val) 0))))
|
||||||
|
|
||||||
|
(defmacro skip-unless (env-var &body body)
|
||||||
|
"Execute body if env-var is set, otherwise skip the test."
|
||||||
|
`(if (has-api-key ,env-var)
|
||||||
|
(progn ,@body)
|
||||||
|
(progn
|
||||||
|
(format t " [SKIP] ~a not set~%" ,env-var)
|
||||||
|
(skip "~a not set" ,env-var))))
|
||||||
|
|
||||||
|
(fiveam:test test-provider-openai-request
|
||||||
|
"Contract Phase2: provider-openai-request returns :success with valid API key."
|
||||||
|
(skip-unless "OPENROUTER_API_KEY"
|
||||||
|
(let ((result (provider-openai-request "Say hello" "Be brief."
|
||||||
|
:provider :openrouter
|
||||||
|
:model "openrouter/auto")))
|
||||||
|
(is (or (eq (getf result :status) :success)
|
||||||
|
(eq (getf result :status) :error))
|
||||||
|
"Expected :success or :error, got: ~a" result))))
|
||||||
|
|
||||||
|
(fiveam:test test-backend-cascade-real
|
||||||
|
"Contract Phase2: backend-cascade-call returns string content with real provider."
|
||||||
|
(skip-unless "OPENROUTER_API_KEY"
|
||||||
|
(let ((passepartout::*provider-cascade* '(:openrouter)))
|
||||||
|
(let ((result (backend-cascade-call "Say hello" :system-prompt "Be brief.")))
|
||||||
|
(is (stringp result) "Expected string response, got: ~a" result)))))
|
||||||
|
|
||||||
|
(fiveam:test test-provider-cascade-parsing
|
||||||
|
"Contract Phase2: PROVIDER_CASCADE env var parses to clean keywords matching backends."
|
||||||
|
(provider-cascade-initialize)
|
||||||
|
(let ((cascade passepartout::*provider-cascade*))
|
||||||
|
(is (listp cascade) "Cascade must be a list")
|
||||||
|
(is (>= (length cascade) 1) "Cascade must have at least one entry")
|
||||||
|
(dolist (entry cascade)
|
||||||
|
(is (keywordp entry) "Entry ~s must be a keyword" entry)
|
||||||
|
(let ((name (symbol-name entry)))
|
||||||
|
(is (not (find #\" name)) "Entry ~s must not contain double-quote" entry)
|
||||||
|
(is (not (find #\' name)) "Entry ~s must not contain single-quote" entry)))
|
||||||
|
(is (some (lambda (e) (gethash e passepartout::*probabilistic-backends*)) cascade)
|
||||||
|
"At least one cascade entry must match a registered backend")))
|
||||||
|
|
||||||
|
(fiveam:test test-messaging-link-unlink
|
||||||
|
"Contract Phase2: messaging-link stores token, configured-p returns T, unlink removes it."
|
||||||
|
(with-daemon ()
|
||||||
|
(messaging-link :test-platform :token "fake-token-123")
|
||||||
|
(is (gateway-configured-p :test-platform)
|
||||||
|
"Expected test-platform to be configured after linking")
|
||||||
|
(messaging-unlink :test-platform)
|
||||||
|
(is (not (gateway-configured-p :test-platform))
|
||||||
|
"Expected test-platform to be unconfigured after unlinking")))
|
||||||
|
|
||||||
|
(fiveam:test test-gateway-configured-p-false
|
||||||
|
"Contract Phase2: gateway-configured-p returns nil for unknown platform."
|
||||||
|
(with-daemon ()
|
||||||
|
(is (not (gateway-configured-p :nonexistent-platform-xyz)))))
|
||||||
|
|
||||||
|
(fiveam:test test-gateway-start-messaging
|
||||||
|
"Contract Phase2: gateway registry initializes with expected platforms."
|
||||||
|
(with-daemon ()
|
||||||
|
(gateway-registry-initialize)
|
||||||
|
(is (hash-table-p passepartout::*gateway-registry*))
|
||||||
|
(is (>= (hash-table-count passepartout::*gateway-registry*) 1))))
|
||||||
|
|
||||||
|
(fiveam:test test-flight-plan-message-format
|
||||||
|
"Contract Phase3: dispatcher-flight-plan-create returns valid message."
|
||||||
|
(with-daemon ()
|
||||||
|
(load (merge-pathnames ".local/share/passepartout/lisp/security-dispatcher.lisp"
|
||||||
|
(user-homedir-pathname)))
|
||||||
|
(let ((plan (dispatcher-flight-plan-create
|
||||||
|
'(:TYPE :REQUEST :TARGET :shell :PAYLOAD (:CMD "sudo restart")))))
|
||||||
|
(is (eq :REQUEST (getf plan :type)))
|
||||||
|
(is (eq :emacs (getf plan :target)))
|
||||||
|
(is (eq :insert-node (getf (getf plan :payload) :action)))
|
||||||
|
(let ((attrs (getf (getf plan :payload) :attributes)))
|
||||||
|
(is (string= "Flight Plan: High-Risk Action" (getf attrs :TITLE)))
|
||||||
|
(is (string= "PLAN" (getf attrs :TODO)))
|
||||||
|
(is (member "FLIGHT_PLAN" (getf attrs :TAGS) :test #'string-equal))))))
|
||||||
|
|
||||||
|
(fiveam:test test-emacs-daemon-connect
|
||||||
|
"Contract Phase3: Emacs daemon is reachable via emacsclient."
|
||||||
|
(handler-case
|
||||||
|
(let ((result (uiop:run-program '("emacsclient" "--eval" "(+ 1 2)")
|
||||||
|
:output :string
|
||||||
|
:ignore-error-status t)))
|
||||||
|
(is (search "3" result) "Expected '3' from emacsclient, got: ~a" result))
|
||||||
|
(error (c)
|
||||||
|
(skip "Emacs daemon not available: ~a" c)))))
|
||||||
@@ -37,7 +37,7 @@ Event handlers + daemon I/O + main loop.
|
|||||||
(defun on-key (ch)
|
(defun on-key (ch)
|
||||||
(cond
|
(cond
|
||||||
;; v0.7.1: Esc — interrupt streaming
|
;; v0.7.1: Esc — interrupt streaming
|
||||||
((and (eq ch :escape) (st :streaming-text))
|
((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text))
|
||||||
(send-daemon (list :type :event :payload '(:action :cancel-stream)))
|
(send-daemon (list :type :event :payload '(:action :cancel-stream)))
|
||||||
(when (> (length (st :messages)) 0)
|
(when (> (length (st :messages)) 0)
|
||||||
(let ((idx (1- (length (st :messages)))))
|
(let ((idx (1- (length (st :messages)))))
|
||||||
@@ -164,7 +164,7 @@ Event handlers + daemon I/O + main loop.
|
|||||||
(on-key ch)
|
(on-key ch)
|
||||||
(return-from on-key nil))
|
(return-from on-key nil))
|
||||||
;; Enter
|
;; Enter
|
||||||
((or (eq ch :enter) (eql ch 13) (eql ch 10)
|
((or (eq ch :enter) (eql ch 13) (eql ch 10) (eql ch 343)
|
||||||
(eql ch #\Newline) (eql ch #\Return))
|
(eql ch #\Newline) (eql ch #\Return))
|
||||||
;; Multi-line: if buffer ends with \, strip it and insert newline
|
;; Multi-line: if buffer ends with \, strip it and insert newline
|
||||||
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
|
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
|
||||||
@@ -555,7 +555,7 @@ Event handlers + daemon I/O + main loop.
|
|||||||
(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 263)
|
||||||
(eql ch #\Backspace))
|
(eql ch #\Backspace))
|
||||||
(input-delete-char)
|
(input-delete-char)
|
||||||
(setf (st :dirty) (list nil nil t)))
|
(setf (st :dirty) (list nil nil t)))
|
||||||
@@ -1172,7 +1172,7 @@ Event handlers + daemon I/O + main loop.
|
|||||||
(fiveam:is (eq :white (getf *tui-theme* :agent)))
|
(fiveam:is (eq :white (getf *tui-theme* :agent)))
|
||||||
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
|
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
|
||||||
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
|
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
|
||||||
(fiveam:is (eq :white (theme-color :unknown-role))))
|
(fiveam:is (string= "#FFFFFF" (theme-color :unknown-role))))
|
||||||
|
|
||||||
(fiveam:test test-on-key-ctrl-u-clears
|
(fiveam:test test-on-key-ctrl-u-clears
|
||||||
"Contract 1/v0.7.0: Ctrl+U clears the input buffer."
|
"Contract 1/v0.7.0: Ctrl+U clears the input buffer."
|
||||||
|
|||||||
173
org/channel-tui.org
Normal file
173
org/channel-tui.org
Normal file
@@ -0,0 +1,173 @@
|
|||||||
|
#+TITLE: Passepartout TUI
|
||||||
|
#+PROPERTY: header-args:lisp :tangle ../lisp/channel-tui.lisp
|
||||||
|
|
||||||
|
* TUI
|
||||||
|
|
||||||
|
Direct-rendering TUI using cl-tty backend + framebuffer. Layout by
|
||||||
|
~compute-layout~. Three zones: status (3 lines), chat, input.
|
||||||
|
|
||||||
|
#+begin_src lisp :tangle ../lisp/channel-tui.lisp
|
||||||
|
(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))))))
|
||||||
|
#+end_src
|
||||||
Reference in New Issue
Block a user