amr/passepartout
1
0
Fork 0
Code Issues 15 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

ARCH: Microkernel Decoupling - Moved State Persistence to user-space dynamic skill

Browse Source
This commit is contained in:
Amr Gharbeia
2026-04-13 15:48:14 -04:00
parent dcd3a31112
commit 34f59a6e43
19 changed files with 204 additions and 279 deletions
Download Patch File Download Diff File Expand all files Collapse all files

39
src/communication-validator.lisp Normal file
View File

@@ -0,0 +1,39 @@
(in-package :org-agent)
(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 (getf msg :type)))
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG))
(error "Communication Protocol Schema Error: Invalid message type '~a'" type))
(case type
(:REQUEST
(unless (getf msg :target)
(error "Communication Protocol Schema Error: REQUEST missing mandatory :target"))
(unless (getf msg :payload)
(error "Communication Protocol Schema Error: REQUEST missing mandatory :payload")))
(:EVENT
(let ((payload (getf msg :payload)))
(unless (and payload (listp payload))
(error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
(unless (or (getf payload :action) (getf payload :sensor))
(error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
(:RESPONSE
(unless (getf 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))

18
src/communication.lisp
View File

@@ -11,10 +11,10 @@
"Prefixes MSG-STRING with a 6-character hex length.
If security is enabled, prefixes a 64-char HMAC-SHA256 signature."
(let ((len (length msg-string))
(enforce-hmac (uiop:getenv "HARNESS_PROTOCOL_ENFORCE_HMAC")))
(enforce-hmac (uiop:getenv "COMMUNICATION_PROTOCOL_ENFORCE_HMAC")))
(if (and enforce-hmac (string-equal enforce-hmac "true"))
(let ((secret (uiop:getenv "HARNESS_PROTOCOL_HMAC_SECRET")))
(unless secret (error "HARNESS_PROTOCOL_HMAC_SECRET is required when security is enabled."))
(let ((secret (uiop:getenv "COMMUNICATION_PROTOCOL_HMAC_SECRET")))
(unless secret (error "COMMUNICATION_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)))
@@ -27,11 +27,11 @@
"Extracts and parses the S-expression from a framed string securely."
(when (< (length framed-string) 6)
(error "Framed string too short"))
(let* ((enforce-hmac (uiop:getenv "HARNESS_PROTOCOL_ENFORCE_HMAC"))
(let* ((enforce-hmac (uiop:getenv "COMMUNICATION_PROTOCOL_ENFORCE_HMAC"))
(use-hmac (and enforce-hmac (string-equal enforce-hmac "true")))
(prefix-len (if use-hmac 70 6)))
(when (< (length framed-string) prefix-len)
(error "Framed string too short for Harness Communication prefix"))
(error "Framed string too short for communication protocol prefix"))
(let* ((len-str (subseq framed-string 0 6))
(signature (when use-hmac (subseq framed-string 6 70)))
@@ -43,20 +43,20 @@
(error "Message length mismatch. Expected ~a, got ~a" expected-len (length actual-msg)))
(when use-hmac
(let ((secret (uiop:getenv "HARNESS_PROTOCOL_HMAC_SECRET")))
(unless secret (error "HARNESS_PROTOCOL_HMAC_SECRET is required when security is enabled."))
(let ((secret (uiop:getenv "COMMUNICATION_PROTOCOL_HMAC_SECRET")))
(unless secret (error "COMMUNICATION_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 actual-msg)))
(ironclad:update-mac hmac payload-bytes)
(let ((expected-signature (ironclad:byte-array-to-hex-string (ironclad:produce-mac hmac))))
(unless (string-equal signature expected-signature)
(error "Harness Communication Integrity Failure: HMAC mismatch"))))))
(error "communication protocol Integrity Failure: HMAC mismatch"))))))
;; SECURITY: Disable the reader's ability to execute code during parsing
(let ((*read-eval* nil))
(let ((msg (read-from-string actual-msg)))
(validate-harness-protocol-schema msg)
(validate-communication-protocol-schema msg)
msg)))))
(defun make-hello-message (version)

12
src/org-agent.el
View File

@@ -12,7 +12,7 @@
;; org-agent provides a Probabilistic-Deterministic Lisp Machine interface for Emacs.
;; It acts as the sensor/actuator array, communicating with a persistent
;; Common Lisp daemon over a high-speed Harness Communication socket.
;; Common Lisp daemon over a high-speed communication protocol socket.
;;; Code:
@@ -100,7 +100,7 @@ will assume you have started it manually (e.g., via SBCL)."
(message "org-agent: Killed daemon process.")))
(defun org-agent--filter (proc string)
"Handle incoming Harness Communication messages from the daemon via PROC with STRING."
"Handle incoming communication protocol messages from the daemon via PROC with STRING."
(let ((buf (process-buffer proc)))
(when (buffer-live-p buf)
(with-current-buffer buf
@@ -109,7 +109,7 @@ will assume you have started it manually (e.g., via SBCL)."
(org-agent--process-buffer buf proc)))))
(defun org-agent--process-buffer (buffer &optional proc)
"Process the Harness Communication message BUFFER, optionally using PROC."
"Process the communication protocol message BUFFER, optionally using PROC."
(with-current-buffer buffer
(goto-char (point-min))
(while (>= (buffer-size) 6)
@@ -127,13 +127,13 @@ will assume you have started it manually (e.g., via SBCL)."
(setq msg-len 1000000)))))) ; Break loop
(defun org-agent--plist-get (plist prop)
"Case-insensitive keyword lookup for Harness Communication compatibility."
"Case-insensitive keyword lookup for communication protocol compatibility."
(or (plist-get plist prop)
(plist-get plist (intern (upcase (symbol-name prop))))
(plist-get plist (intern (downcase (symbol-name prop))))))
(defun org-agent--handle-message (proc plist)
"Route and execute incoming Harness Communication messages from PROC using PLIST."
"Route and execute incoming communication protocol messages from PROC using PLIST."
(let ((type (org-agent--plist-get plist :type))
(id (org-agent--plist-get plist :id))
(payload (or (org-agent--plist-get plist :payload) plist)))
@@ -190,7 +190,7 @@ will assume you have started it manually (e.g., via SBCL)."
(message "org-agent: Connection lost.")))
(defun org-agent-send (plist)
"Send a Lisp PLIST to the daemon using Harness Communication framing."
"Send a Lisp PLIST to the daemon using communication protocol framing."
(let* ((msg (prin1-to-string plist))
(len (length msg))
(framed (format "%06x%s" len msg)))

5
src/package.lisp
View File

@@ -1,11 +1,11 @@
(defpackage :org-agent
(:use :cl)
(:export
;; --- Harness Communication ---
;; --- communication protocol ---
#:frame-message
#:parse-message
#:make-hello-message
#:validate-harness-protocol-schema
#:validate-communication-protocol-schema
;; --- Daemon Lifecycle ---
#:start-daemon
@@ -20,6 +20,7 @@
#:*memory*
#:*history-store*
#:org-object
#:make-org-object
#:org-object-id
#:org-object-type
#:org-object-attributes

22
src/protocol-validator.lisp
View File

@@ -1,39 +1,39 @@
(in-package :org-agent)
(defun validate-harness-protocol-schema (msg)
"Strict structural validation for incoming Harness Communication messages."
(defun validate-communication-protocol-schema (msg)
"Strict structural validation for incoming communication protocol messages."
(unless (listp msg)
(error "Harness Communication Schema Error: Message must be a property list (got ~s)" (type-of msg)))
(error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg)))
(let ((type (getf msg :type)))
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG))
(error "Harness Communication Schema Error: Invalid message type '~a'" type))
(error "Communication Protocol Schema Error: Invalid message type '~a'" type))
(case type
(:REQUEST
(unless (getf msg :target)
(error "Harness Communication Schema Error: REQUEST missing mandatory :target"))
(error "Communication Protocol Schema Error: REQUEST missing mandatory :target"))
(unless (getf msg :payload)
(error "Harness Communication Schema Error: REQUEST missing mandatory :payload")))
(error "Communication Protocol Schema Error: REQUEST missing mandatory :payload")))
(:EVENT
(let ((payload (getf msg :payload)))
(unless (and payload (listp payload))
(error "Harness Communication Schema Error: EVENT missing or invalid :payload"))
(error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
(unless (or (getf payload :action) (getf payload :sensor))
(error "Harness Communication Schema Error: EVENT payload must contain :action or :sensor"))))
(error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
(:RESPONSE
(unless (getf msg :payload)
(error "Harness Communication Schema Error: RESPONSE missing mandatory :payload"))))
(error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload"))))
t))
(defskill :skill-harness-protocol-validator
(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-harness-protocol-schema action)
(validate-communication-protocol-schema action)
action))

125
src/state-persistence.lisp
View File

@@ -1,125 +0,0 @@
(in-package :org-agent)
(defun persistence-get-local-path ()
"Returns the path to the local memory image file."
(let ((state-dir (or (uiop:getenv "SYSTEM_DIR") "system/")))
(merge-pathnames "state/memory-image.lisp" state-dir)))
(defun persistence-dump-local ()
"Serializes the entire history store and current pointers to a local Lisp image."
(let ((image-file (persistence-get-local-path)))
(ensure-directories-exist image-file)
(harness-log "PERSISTENCE - Dumping local image to ~a..." (uiop:native-namestring image-file))
(with-open-file (out image-file :direction :output :if-exists :supersede)
(format out "(in-package :org-agent)~%")
;; 1. Dump all immutable objects in the history store
(maphash (lambda (hash obj)
(print `(setf (gethash ,hash *history-store*) ,obj) out))
*history-store*)
;; 2. Dump the current active pointers
(maphash (lambda (id obj)
(print `(setf (gethash ,id *memory*) (gethash ,(org-object-hash obj) *history-store*)) out))
*memory*))
t))
(defun persistence-load-local ()
"Loads the memory image from local disk."
(let ((image-file (persistence-get-local-path)))
(if (uiop:file-exists-p image-file)
(progn
(harness-log "PERSISTENCE - Loading local image...")
(load image-file)
t)
(progn
(harness-log "PERSISTENCE ERROR - Local image not found.")
nil))))
(defun persistence-serialize-for-archival ()
"Serializes the entire object-store for IPFS/JSON transport."
(let ((objects nil))
(maphash (lambda (id obj)
(declare (ignore id))
(push `((:id . ,(org-object-id obj))
(:type . ,(format nil "~s" (org-object-type obj)))
(:attributes . ,(loop for (k v) on (org-object-attributes obj) by #'cddr
collect (cons (format nil "~a" k) (format nil "~a" v))))
(:content . ,(org-object-content obj))
(:parent-id . ,(org-object-parent-id obj))
(:children . ,(org-object-children obj))
(:version . ,(org-object-version obj))
(:last-sync . ,(org-object-last-sync obj))
(:hash . ,(org-object-hash obj)))
objects))
*memory*)
objects))
(defun persistence-push-ipfs ()
"Serializes the store and pushes it to IPFS, returning the CID."
(let* ((data (persistence-serialize-for-archival))
(json-payload (cl-json:encode-json-to-string data))
(ipfs-url "http://127.0.0.1:5001/api/v0/add"))
(handler-case
(let* ((response (dex:post ipfs-url
:content `(("file" . ,json-payload))
:headers '(("Content-Type" . "multipart/form-data"))))
(result (cl-json:decode-json-from-string response))
(cid (cdr (assoc :hash result))))
(harness-log "PERSISTENCE - Checkpoint to IPFS successful. CID: ~a" cid)
cid)
(error (c)
(harness-log "PERSISTENCE ERROR - IPFS push failed: ~a" c)
nil))))
(defun persistence-restore-ipfs (cid)
"Fetches data from IPFS and safely hydrates the object-store."
(let ((ipfs-url (format nil "http://127.0.0.1:5001/api/v0/cat?arg=~a" cid)))
(handler-case
(let* ((response (dex:post ipfs-url))
(data (cl-json:decode-json-from-string response)))
(clrhash *memory*)
(dolist (item data)
(let* ((id (cdr (assoc :id item)))
(obj (make-org-object
:id id
:type (read-from-string (cdr (assoc :type item)))
:attributes (loop for attr in (cdr (assoc :attributes item))
append (list (intern (string-upcase (car attr)) :keyword) (cdr attr)))
:content (cdr (assoc :content item))
:parent-id (cdr (assoc :parent-id item))
:children (cdr (assoc :children item))
:version (cdr (assoc :version item))
:last-sync (cdr (assoc :last-sync item))
:hash (cdr (assoc :hash item)))))
(setf (gethash id *memory*) obj)))
(harness-log "PERSISTENCE - Restored from IPFS: ~a" cid)
t)
(error (c)
(harness-log "PERSISTENCE ERROR - IPFS restoration failed: ~a" c)
nil))))
(progn
(def-cognitive-tool :checkpoint-memory "Creates both a local image and a decentralized IPFS snapshot."
:parameters nil
:body (lambda (args)
(declare (ignore args))
(persistence-dump-local)
(let ((cid (persistence-push-ipfs)))
(format nil "Local dump complete. IPFS CID: ~a" (or cid "FAILED")))))
(def-cognitive-tool :restore-memory "Restores the state from a specific source."
:parameters ((:source :type :keyword :description "Either :LOCAL or :IPFS")
(:cid :type :string :description "Required if source is :IPFS"))
:body (lambda (args)
(case (getf args :source)
(:local (if (persistence-load-local) "Restored from disk." "Local restore failed."))
(:ipfs (if (persistence-restore-ipfs (getf args :cid)) "Restored from network." "IPFS restore failed."))))))
(defskill :skill-state-persistence
:priority 100
:trigger (lambda (ctx)
(let ((sensor (getf (getf ctx :payload) :sensor)))
(member sensor '(:heartbeat :manual-persist))))
:probabilistic nil
:deterministic (lambda (action ctx)
(persistence-dump-local)
action))