From 3e184ad344fa5560ba7d3c4202444887ddec44da Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Sun, 19 Apr 2026 20:31:06 -0400 Subject: [PATCH] fix(protocol): Revert to Hardened S-expressions (Lisp Purity restoration) --- literate/communication.org | 45 +++++++++++++++----------------------- src/communication.lisp | 45 +++++++++++++++----------------------- 2 files changed, 36 insertions(+), 54 deletions(-) diff --git a/literate/communication.org b/literate/communication.org index 22c52f2..dc8315e 100644 --- a/literate/communication.org +++ b/literate/communication.org @@ -62,21 +62,12 @@ The system maintains a decoupled registry of target actuators. This allows the s The ~frame-message~ function prepares an outgoing Lisp string for transmission. It calculates the byte length, converts it into a 6-character padded hex string, and prefixes it. If ~PROTOCOL_ENFORCE_HMAC~ is enabled in the environment, it also prepends a cryptographic signature to ensure the message hasn't been tampered with. #+begin_src lisp :tangle ../src/communication.lisp -(defun frame-message (msg-string) - "Prefixes MSG-STRING with a 6-character hex length. - If security is enabled, prefixes a 64-char HMAC-SHA256 signature." - (let ((*print-pretty* nil) (len (length msg-string)) - (enforce-hmac (uiop:getenv "PROTOCOL_ENFORCE_HMAC"))) - (if (and enforce-hmac (string-equal enforce-hmac "true")) - (let ((secret (uiop:getenv "PROTOCOL_HMAC_SECRET"))) - (unless secret (error "PROTOCOL_HMAC_SECRET is required when security is enabled.")) - (let* ((key (ironclad:ascii-string-to-byte-array secret)) - (hmac (ironclad:make-mac :hmac key :sha256)) - (payload-bytes (ironclad:ascii-string-to-byte-array msg-string))) - (ironclad:update-mac hmac payload-bytes) - (let ((signature (ironclad:byte-array-to-hex-string (ironclad:produce-mac hmac)))) - (format nil "~(~6,'0x~)~a~a" len signature msg-string)))) - (format nil "~(~6,'0x~)~a" len msg-string)))) +(defun frame-message (msg-plist) + "Frames a Lisp plist with a 6-char hex length and a newline sentinel for stream integrity." + (let* ((*print-pretty* nil) + (msg-string (format nil "~s" msg-plist)) + (len (length msg-string))) + (format nil "~6,'0x~a~%" len msg-string))) #+end_src ** Message Parsing (parse-message) @@ -138,11 +129,11 @@ A robust utility to read a framed message from a stream. It enforces the determi #+begin_src lisp :tangle ../src/communication.lisp (defun read-framed-message (stream) - "Reads a hex-length prefixed JSON message from the stream." + "Robustly reads a hex-framed S-expression, skipping leading whitespace and handling desync." (let ((length-buffer (make-string 6))) (handler-case (progn - ;; Skip leading junk (newlines, etc.) + ;; 1. Skip leading junk until we find a hex digit (the start of a length prefix) (loop for char = (peek-char nil stream nil :eof) while (and (not (eq char :eof)) (not (digit-char-p char 16))) do (read-char stream)) @@ -153,14 +144,14 @@ A robust utility to read a framed message from a stream. It enforces the determi (if (not len) :error (let ((msg-buffer (make-string len))) (read-sequence msg-buffer stream) - (let ((msg (cl-json:decode-json-from-string msg-buffer))) - ;; Convert JSON alist back to plist for kernel compatibility - (let ((plist nil)) - (dolist (pair msg) - (push (intern (string-upcase (string (car pair))) :keyword) plist) - (push (cdr pair) plist)) - (let ((final (nreverse plist))) - (validate-communication-protocol-schema final) - final))))))))) - (error (c) (harness-log "PROTOCOL ERROR: ~a" c) :error)))) + (let ((*read-eval* nil) + (*print-pretty* nil)) + (handler-case + (let ((msg (read-from-string msg-buffer))) + (validate-communication-protocol-schema msg) + msg) + (error (c) + (harness-log "PROTOCOL PARSE ERROR: ~a in ~s" c msg-buffer) + :error))))))))) + (error (c) (harness-log "PROTOCOL READ ERROR: ~a" c) :error)))) #+end_src diff --git a/src/communication.lisp b/src/communication.lisp index abc19b5..147260f 100644 --- a/src/communication.lisp +++ b/src/communication.lisp @@ -7,21 +7,12 @@ "Registers an actuator function. Actuators receive: (ACTION CONTEXT)." (setf (gethash name *actuator-registry*) fn)) -(defun frame-message (msg-string) - "Prefixes MSG-STRING with a 6-character hex length. - If security is enabled, prefixes a 64-char HMAC-SHA256 signature." - (let ((*print-pretty* nil) (len (length msg-string)) - (enforce-hmac (uiop:getenv "PROTOCOL_ENFORCE_HMAC"))) - (if (and enforce-hmac (string-equal enforce-hmac "true")) - (let ((secret (uiop:getenv "PROTOCOL_HMAC_SECRET"))) - (unless secret (error "PROTOCOL_HMAC_SECRET is required when security is enabled.")) - (let* ((key (ironclad:ascii-string-to-byte-array secret)) - (hmac (ironclad:make-mac :hmac key :sha256)) - (payload-bytes (ironclad:ascii-string-to-byte-array msg-string))) - (ironclad:update-mac hmac payload-bytes) - (let ((signature (ironclad:byte-array-to-hex-string (ironclad:produce-mac hmac)))) - (format nil "~(~6,'0x~)~a~a" len signature msg-string)))) - (format nil "~(~6,'0x~)~a" len msg-string)))) +(defun frame-message (msg-plist) + "Frames a Lisp plist with a 6-char hex length and a newline sentinel for stream integrity." + (let* ((*print-pretty* nil) + (msg-string (format nil "~s" msg-plist)) + (len (length msg-string))) + (format nil "~6,'0x~a~%" len msg-string))) (defun parse-message (framed-string) "Extracts and parses the S-expression from a framed string securely." @@ -67,11 +58,11 @@ :capabilities '(:auth :swank :org-ast)))) (defun read-framed-message (stream) - "Reads a hex-length prefixed JSON message from the stream." + "Robustly reads a hex-framed S-expression, skipping leading whitespace and handling desync." (let ((length-buffer (make-string 6))) (handler-case (progn - ;; Skip leading junk (newlines, etc.) + ;; 1. Skip leading junk until we find a hex digit (the start of a length prefix) (loop for char = (peek-char nil stream nil :eof) while (and (not (eq char :eof)) (not (digit-char-p char 16))) do (read-char stream)) @@ -82,13 +73,13 @@ (if (not len) :error (let ((msg-buffer (make-string len))) (read-sequence msg-buffer stream) - (let ((msg (cl-json:decode-json-from-string msg-buffer))) - ;; Convert JSON alist back to plist for kernel compatibility - (let ((plist nil)) - (dolist (pair msg) - (push (intern (string-upcase (string (car pair))) :keyword) plist) - (push (cdr pair) plist)) - (let ((final (nreverse plist))) - (validate-communication-protocol-schema final) - final))))))))) - (error (c) (harness-log "PROTOCOL ERROR: ~a" c) :error)))) + (let ((*read-eval* nil) + (*print-pretty* nil)) + (handler-case + (let ((msg (read-from-string msg-buffer))) + (validate-communication-protocol-schema msg) + msg) + (error (c) + (harness-log "PROTOCOL PARSE ERROR: ~a in ~s" c msg-buffer) + :error))))))))) + (error (c) (harness-log "PROTOCOL READ ERROR: ~a" c) :error))))