passepartout: v0.5.0 hotfix 2 — daemon stable

- Restore (in-package :passepartout) to core-reason
- Move *VAULT-MEMORY* back to core-skills
- Fix ASDF and defstruct/defpackage ordering
- Increase daemon timeout to 120s
- Handshake: 0.5.0

Verified: daemon processes messages, TUI clean, gate trace works

lisp/core-transport.lisp

@@ -0,0 +1,161 @@
+(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)
+                while (and (not (eq char :eof)) (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)
+
+(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.5.0")))
+          (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))
+  "Starts the network listener for TUI/CLI clients."
+  (setf *daemon-socket* (usocket:socket-listen "127.0.0.1" port :reuse-address t))
+  (log-message "DAEMON: Listening on localhost:~a" port)
+  (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"))
+
+(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))))