passepartout/org/gateway-tui.org

Passepartout TUI Client

• Package + Model
• Helpers
• View
• Event Queue
• Event Handlers
• Daemon I/O
• Connection
• Redraw
• Main

Package + Model

(defpackage :passepartout.gateway-tui
  (:use :cl :croatoan :passepartout :usocket :bordeaux-threads)
  (:export :tui-main))
(in-package :passepartout.gateway-tui)

(defvar *state* nil)
(defvar *event-queue* nil)
(defvar *event-lock* (bt:make-lock "tui-event-lock"))

(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 nil :scroll-offset 0 :dirty (list nil nil nil))))

Helpers

(defun now ()
  (multiple-value-bind (h m) (get-decoded-time)
    (format nil "~2,'0d:~2,'0d" h m)))

(defun input-string ()
  (coerce (reverse (st :input-buffer)) 'string))

(defun add-msg (role content)
  (push (list :role role :content content :time (now)) (st :messages))
  (setf (st :dirty) (list t t nil)))

View

(defun view-status (win)
  (clear win)
  (box win 0 0)
  (add-string win
   (format nil " Passepartout  ~a  [~a]  msgs:~a  scroll:~a"
           (if (st :connected) "● Connected" "○ Disconnected")
           (string-upcase (string (st :mode)))
           (length (st :messages))
           (if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0"))
   :y 1 :x 1 :fgcolor (if (st :connected) :green :red))
  (add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor :yellow)
  (refresh win))

(defun view-chat (win h)
  (clear win)
  (box win 0 0)
  (let* ((w (or (width win) 78))
         (msgs (reverse (st :messages)))
         (max-lines (- h 2))
         (total (length msgs))
         (start (max 0 (- total max-lines (st :scroll-offset))))
         (y 1))
    (loop for i from start below total
          while (< y (1- h))
          do (let ((msg (nth i msgs)))
               (let* ((role (getf msg :role))
                      (content (getf msg :content))
                      (time (or (getf msg :time) ""))
                      (label (case role
                               (:user (format nil "⬆ [~a] ~a" time content))
                               (:agent (format nil "⬇ [~a] ~a" time content))
                               (:system (format nil "   [~a] ~a" time content))
                               (t (format nil "   [~a] ~a" time content))))
                      (color (case role
                               (:user :green)
                               (:agent :white)
                               (:system :yellow)
                               (t :white))))
                 (add-string win label :y y :x 1 :n (1- w) :fgcolor color)
                 (incf y)))))
  (refresh win))

(defun view-input (win)
  (let* ((text (input-string))
         (w (or (width win) 78))
         (clip (min (length text) (1- w))))
    (clear win)
    (add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor :cyan)
    (setf (cursor-position win) (list 0 clip)))
  (refresh win))

Event Queue

(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)))

Event Handlers

(defun on-key (&rest args)
  (let ((ch (car args)))
    (cond
      ((or (eql ch 10) (eql ch 13) (eq ch :enter)
           (eql ch #\Newline) (eql ch #\Return))
       (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
             ;; /eval command: evaluate Lisp form
             ((and (>= (length text) 6)
                   (string-equal (subseq text 0 6) "/eval "))
              (handler-case
                  (let* ((*read-eval* t)
                         (*package* (find-package :passepartout.gateway-tui))
                         (r (eval (read-from-string (subseq text 6)))))
                    (add-msg :system (format nil "=> ~s" r)))
                (error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
             ;; Normal message: send to daemon
             (t
              (add-msg :user text)
              (send-daemon (list :type :event
                                :payload (list :sensor :user-input :text text)))))
           (setf (st :input-buffer) nil)
           (setf (st :dirty) (list t t t)))))
      ((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
       (when (st :input-buffer) (pop (st :input-buffer)))
       (setf (st :dirty) (list nil nil t)))
      ((or (eq ch :up) (eql ch 259))
       (let* ((h (st :input-history)) (p (st :input-hpos)))
         (when (and h (< p (1- (length h))))
           (incf (st :input-hpos))
           (setf (st :input-buffer)
                 (reverse (coerce (nth (st :input-hpos) h) 'list)))
           (setf (st :dirty) (list nil nil t)))))
      ((or (eq ch :down) (eql ch 258))
       (when (> (st :input-hpos) 0)
         (decf (st :input-hpos))
         (let ((h (st :input-history)))
           (setf (st :input-buffer)
                 (if (and h (< (st :input-hpos) (length h)))
                     (reverse (coerce (nth (st :input-hpos) h) 'list))
                     nil))
           (setf (st :dirty) (list nil nil t)))))
      ((or (eq ch :ppage) (eql ch 339))
       (incf (st :scroll-offset) 5)
       (setf (st :dirty) (list nil t nil)))
      ((or (eq ch :npage) (eql ch 338))
       (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
       (setf (st :dirty) (list nil t nil)))
      (t
       (let ((chr (typecase ch
                    (character ch)
                    (integer (code-char ch))
                    (t nil))))
         (when (and chr (graphic-char-p chr))
           (push chr (st :input-buffer))
           (setf (st :dirty) (list nil nil t))))))))

(defun on-daemon-msg (msg)
  (let* ((payload (getf msg :payload))
         (text (getf payload :text))
         (action (getf payload :action)))
    (cond
      (text (add-msg :agent text))
      ((eq action :handshake)
       (add-msg :system (format nil "Connected v~a" (getf payload :version))))
      (t (add-msg :agent (format nil "~a" msg))))))

Daemon I/O

(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 (c) (log-message "TUI-SEND: ~a" c))))))

(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 (c) (log-message "TUI-RECV: ~a" c) nil)))

(defun reader-loop (s)
  (loop while (and (st :running) (open-stream-p s))
        do (let ((msg (recv-daemon s)))
             (when msg (queue-event (list :type :daemon :payload msg))))))

Connection

(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
  (handler-case
      (let ((s (usocket:socket-connect host port :element-type 'character)))
        (setf (st :stream) (usocket:socket-stream s) (st :connected) t)
        (bt:make-thread (lambda () (reader-loop (st :stream))) :name "tui-reader")
        (add-msg :system "* Connected *")
        t)
    (error (c)
      (add-msg :system (format nil "* Connection failed: ~a *" c))
      nil)))

(defun disconnect-daemon ()
  (when (st :stream)
    (ignore-errors (close (st :stream)))
    (setf (st :stream) nil (st :connected) nil)
    (add-msg :system "* Disconnected *")))

Redraw

(defun redraw (sw cw ch iw)
  (destructuring-bind (sd cd id) (st :dirty)
    (when sd (view-status sw))
    (when cd (view-chat cw ch))
    (when id (view-input iw))
    (setf (st :dirty) (list nil nil nil))))

Main

(defun tui-main ()
  (init-state)
  (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
    (let* ((h (or (height scr) 24))
           (w (or (width scr) 80))
           (sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1))
           (ch (- h 5))
           (cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1))
           (iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1))
           (swank-port (or (ignore-errors
                             (parse-integer (uiop:getenv "TUI_SWANK_PORT")))
                           4006)))
      (setf (function-keys-enabled-p iw) t
            (st :dirty) (list t t t))
      (connect-daemon)
      ;; Start Swank REPL (optional - set TUI_SWANK_PORT=0 to disable)
      (when (> swank-port 0)
        (handler-case
            (progn
              (ql:quickload :swank :silent t)
              (funcall (find-symbol "CREATE-SERVER" "SWANK")
                       :port swank-port :dont-close t)
              (add-msg :system
                       (format nil "* Swank ~d  M-x slime-connect *" swank-port)))
          (error (c)
            (add-msg :system "* Swank unavailable *"))))
      ;; Main loop
      (loop while (st :running) do
        (dolist (ev (drain-queue))
          (when (eq (getf ev :type) :daemon)
            (on-daemon-msg (getf ev :payload))))
        (let ((ch (get-char iw)))
          (when (and ch (not (equal ch -1)))
            (on-key ch)))
        (redraw sw cw ch iw)
        (refresh scr)
        (sleep 0.03))
      (disconnect-daemon))))