#+TITLE: Communication Protocol (communication.lisp)
#+AUTHOR: Amr
#+FILETAGS: :harness:protocol:
#+STARTUP: content

* Communication Protocol (communication.lisp)
** Architectural Intent: Secure Inter-Process Communication & Deterministic Framing

The ~communication.lisp~ module defines the low-level transport and framing logic for OpenCortex stimuli. 

* Implementation (communication.lisp)

#+begin_src lisp :tangle ../library/communication.lisp
(in-package :opencortex)

(defun proto-get (plist key)
  "Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
  (let* ((s (string key))
         (up (intern (string-upcase s) :keyword))
         (dn (intern (string-downcase s) :keyword)))
    (or (getf plist up) (getf plist dn))))
#+end_src

#+begin_src lisp :tangle ../library/communication.lisp
(in-package :opencortex)

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

;; Removed duplicate frame-message - kept the sanitized version below

(defun read-framed-message (stream)
  "Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
  (let ((length-buffer (make-string 6)))
    (handler-case
        (progn
          ;; 1. Skip leading whitespace (newlines, spaces, etc.)
          (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))
          
          ;; 2. Read the 6-char hex length
          (let ((count (read-sequence length-buffer stream)))
            (cond ((< count 6) :eof)
                  (t (let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
                       (if (not len)
                           (progn
                             (harness-log "PROTOCOL ERROR: Invalid header ~s. Attempting resync..." length-buffer)
                             :error)
                           (let ((msg-buffer (make-string len)))
                             (read-sequence msg-buffer stream)
                             (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))))

(defun make-hello-message (version)
  "Constructs the standard HELLO handshake message."
  (list :TYPE :EVENT 
        :PAYLOAD (list :ACTION :handshake 
                       :VERSION version 
                       :CAPABILITIES '(:AUTH :SWANK :ORG-AST))))
#+end_src

** Structural Validation (communication-validator.lisp)
The validator ensures that incoming messages adhere to the strict property list schema of the communication protocol.

#+begin_src lisp :tangle ../library/communication-validator.lisp
(in-package :opencortex)

(defun validate-communication-protocol-schema (msg)
  "Strict structural validation for incoming communication protocol messages."
  (unless (listp msg)
    (error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg)))
  
  (let ((type (let ((raw (proto-get msg :type))) (if (keywordp raw) (intern (string-upcase (string raw)) :keyword) raw))))
    (unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
      (progn (harness-log "REJECTED MSG: ~s" msg) (error "Communication Protocol Schema Error: Invalid message type '~a'" type)))
    
    (case type
      (:REQUEST 
       ;; Allow missing :target if :source is present in :meta, since reason-gate
       ;; will infer :target from :source downstream. This preserves "equality of
       ;; clients" — gateways need not duplicate routing logic.
       (let ((target (proto-get msg :target))
             (source (proto-get (proto-get msg :meta) :source)))
         (unless (or target source)
           (error "Communication Protocol Schema Error: REQUEST missing mandatory :target and no :source in :meta to infer it"))
         (unless (proto-get msg :payload)
           (error "Communication Protocol Schema Error: REQUEST missing mandatory :payload"))))
      
      (:EVENT
       (let ((payload (proto-get msg :payload)))
         (unless (and payload (listp payload))
           (error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
         (unless (or (proto-get payload :action) (proto-get payload :sensor))
           (error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
      
      (:RESPONSE
       (unless (proto-get msg :payload)
         (error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload"))))
    
    t))

(defskill :skill-communication-protocol-validator
  :priority 95
  :trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received)))
  :probabilistic nil
  :deterministic (lambda (action ctx)
              (declare (ignore ctx))
              (validate-communication-protocol-schema action)
              action))
#+end_src

** Message Framing (communication.lisp)
Frames a message with a hex length prefix and ensures all data is serializable.

#+begin_src lisp :tangle ../library/communication.lisp
(defun sanitize-protocol-message (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) (sanitize-protocol-message 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 (sanitize-protocol-message msg))
         (payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
         (len (length payload)))
    (format nil "~6,'0x~a" len payload)))
#+end_src

* Test Suite

These tests verify the communication protocol functions. Run with:
~(fiveam:run! 'communication-protocol-suite)~

#+begin_src lisp :tangle ../library/communication-tests.lisp
(defpackage :opencortex-communication-tests
  (:use :cl :fiveam :opencortex)
  (:export #:communication-protocol-suite))

(in-package :opencortex-communication-tests)

(def-suite communication-protocol-suite
  :description "Test suite for opencortex Communication Protocol")

(in-suite communication-protocol-suite)

(test test-framing
  "Verify that messages are correctly prefixed with a 6-character hex length."
  (let* ((msg '(:type :EVENT :payload (:action :handshake)))
         (framed (frame-message msg))
         (len-str (subseq framed 0 6))
         (payload (subseq framed 6)))
    (is (string= "00002C" (string-upcase len-str)))
    (is (equalp msg (read-from-string payload)))))

(test test-parse-message
  "Verify that incoming framed strings are parsed into Lisp plists."
  (let ((framed "00002c(:type :EVENT :payload (:action :handshake))"))
    (is (equal '(:type :EVENT :payload (:action :handshake))
               (read-from-string (subseq framed 6))))))

(test test-hello-handshake
  "Verify the structure of the HELLO handshake message."
  (let ((hello (make-hello-message "0.1.0")))
    (is (eq :EVENT (getf hello :type)))
    (is (eq :handshake (getf (getf hello :payload) :action)))
    (is (string= "0.1.0" (getf (getf hello :payload) :version)))))

(test test-find-missing-id
  "Verify that the daemon can find a headline missing an ID."
  (let* ((ast '(:type :org-data :contents
                   ((:type :HEADLINE :properties (:TITLE "No ID Here") :contents nil)
                    (:type :HEADLINE :properties (:ID "exists" :TITLE "Has ID") :contents nil))))
         (found (find-headline-missing-id ast)))
    (is (not (null found)))
    (is (string= "No ID Here" (getf (getf found :properties) :TITLE)))))
#+end_src