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

security: patch OACP reader vulnerability and implement HMAC foundations

Browse Source
This commit is contained in:
Amr Gharbeia
2026-04-08 20:14:57 -04:00
parent 7e14f49204
commit 1cd283ccb3
5 changed files with 124 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
.env.example
View File

@@ -41,3 +41,7 @@ SYSTEM_DIR="/memex/system"
MEMEX_USER="YourName" MEMEX_USER="YourName"
MEMEX_ASSISTANT="AgentName" MEMEX_ASSISTANT="AgentName"
RECIPIENT_ID="+1..." # For Signal/Telegram delivery RECIPIENT_ID="+1..." # For Signal/Telegram delivery
# OACP Integrity & Authentication (HMAC-SHA256)
OACP_ENFORCE_HMAC=false
OACP_HMAC_SECRET="change-this-to-a-secure-random-string"

85
README.org
View File

@@ -325,16 +325,20 @@ sequenceDiagram
nil))) nil)))
(defun perceive (raw-message) (defun perceive (raw-message)
(let ((type (getf raw-message :type)) (payload (getf raw-message :payload))) (handler-case
(kernel-log "PERCEIVE: ~a (~a)" type (or (getf payload :sensor) "no-sensor")) (let ((type (getf raw-message :type)) (payload (getf raw-message :payload)))
(cond ((eq type :EVENT) (let ((sensor (getf payload :sensor))) (kernel-log "PERCEIVE: ~a (~a)" type (or (getf payload :sensor) "no-sensor"))
(case sensor (cond ((eq type :EVENT) (let ((sensor (getf payload :sensor)))
(:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast)))) (case sensor
(:point-update (let ((element (getf payload :element))) (when element (ingest-ast element)))) (:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast))))
(:interrupt (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t)))))) (:point-update (let ((element (getf payload :element))) (when element (ingest-ast element))))
((eq type :RESPONSE) (:interrupt (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t))))))
(kernel-log "ACT RESULT: ~a~%PAYLOAD: ~s~%" (getf payload :status) payload))) ((eq type :RESPONSE)
raw-message)) (kernel-log "ACT RESULT: ~a~%PAYLOAD: ~s~%" (getf payload :status) payload)))
raw-message)
(error (c)
(kernel-log "PERCEIVE ERROR: Malformed stimulus received: ~a" c)
nil)))
(defun start-heartbeat (&optional (interval 60)) (defun start-heartbeat (&optional (interval 60))
(setf *heartbeat-thread* (bt:make-thread (lambda () (loop (sleep interval) (kernel-log "KERNEL: Heartbeat pulse...") (setf *heartbeat-thread* (bt:make-thread (lambda () (loop (sleep interval) (kernel-log "KERNEL: Heartbeat pulse...")
@@ -452,22 +456,53 @@ Streaming raw JSON over a socket is fragile. If a 5MB Org AST is fragmented by t
(in-package :org-agent) (in-package :org-agent)
(defun frame-message (msg-string) (defun frame-message (msg-string)
"Prefix MSG-STRING with a 6-character hex length (lowercase)." "Prefix MSG-STRING with a 6-character hex length (lowercase).
(let ((len (length msg-string))) FUTURE: Will also prefix a 64-char HMAC signature when OACP_ENFORCE_HMAC=true."
(format nil "~(~6,'0x~)~a" len msg-string))) (let ((len (length msg-string))
(enforce-hmac (uiop:getenv "OACP_ENFORCE_HMAC")))
(if (and enforce-hmac (string-equal enforce-hmac "true"))
(let* ((secret (or (uiop:getenv "OACP_HMAC_SECRET") "default-insecure-secret"))
(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 parse-message (framed-string) (defun parse-message (framed-string)
"Extract and parse the S-expression from a framed string." "Extract and parse the S-expression from a framed string, securely preventing reader macro injection."
(when (< (length framed-string) 6) (when (< (length framed-string) 6)
(error "Framed string too short")) (error "Framed string too short"))
(let* ((len-str (subseq framed-string 0 6)) (let* ((enforce-hmac (uiop:getenv "OACP_ENFORCE_HMAC"))
(actual-msg (subseq framed-string 6)) (use-hmac (and enforce-hmac (string-equal enforce-hmac "true")))
(expected-len (ignore-errors (parse-integer len-str :radix 16)))) (prefix-len (if use-hmac 70 6)))
(unless expected-len (when (< (length framed-string) prefix-len)
(error "Invalid hex length prefix: ~a" len-str)) (error "Framed string too short for OACP signature/length"))
(unless (= expected-len (length actual-msg))
(error "Message length mismatch. Expected ~a, got ~a" expected-len (length actual-msg))) (let* ((len-str (subseq framed-string 0 6))
(read-from-string actual-msg))) (signature (when use-hmac (subseq framed-string 6 70)))
(actual-msg (subseq framed-string prefix-len))
(expected-len (ignore-errors (parse-integer len-str :radix 16))))
(unless expected-len
(error "Invalid hex length prefix: ~a" len-str))
(unless (= expected-len (length actual-msg))
(error "Message length mismatch. Expected ~a, got ~a" expected-len (length actual-msg)))
;; HMAC Validation Foundation
(when use-hmac
(let* ((secret (or (uiop:getenv "OACP_HMAC_SECRET") "default-insecure-secret"))
(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 "OACP Integrity Failure: HMAC signature mismatch")))))
;; SECURITY: Prevent Reader Macro Injection (e.g. #. ) during deserialization
(let ((*read-eval* nil))
(read-from-string actual-msg)))))
(defun make-hello-message (version) (defun make-hello-message (version)
"Construct the standard HELLO handshake message." "Construct the standard HELLO handshake message."
@@ -837,17 +872,17 @@ EXAMPLES:
(setf finished :error)))) (setf finished :error))))
:name (format nil "loader-~a" (pathname-name filepath)))) :name (format nil "loader-~a" (pathname-name filepath))))
(start-time (get-internal-real-time)) (start-time (get-internal-real-time))
(timeout-units (* timeout-seconds internal-time-units-per-second))) (timeout-units (truncate (* timeout-seconds internal-time-units-per-second))))
(loop (loop
(when (eq finished t) (return :success)) (when (eq finished t) (return :success))
(when (eq finished :error) (return :error)) (when (eq finished :error) (return :error))
(unless (bt:thread-alive-p thread) (return :error)) (unless (bt:thread-alive-p thread) (return :error))
(when (> (- (get-internal-real-time) start-time) timeout-units) (when (> (- (get-internal-real-time) start-time) timeout-units)
(kernel-log "KERNEL: Timing out skill ~a..." (pathname-name filepath))
#+sbcl (sb-thread:terminate-thread thread) #+sbcl (sb-thread:terminate-thread thread)
#-sbcl (bt:destroy-thread thread) #-sbcl (bt:destroy-thread thread)
(kernel-log "KERNEL ERROR: Timeout loading skill ~a" (pathname-name filepath))
(return :timeout)) (return :timeout))
(sleep 0.1)))) (sleep 0.05))))
(defun load-skill-from-org (filepath) (defun load-skill-from-org (filepath)
(when (uiop:file-exists-p filepath) (when (uiop:file-exists-p filepath)

24
src/core.lisp
View File

@@ -138,16 +138,20 @@
nil))) nil)))
(defun perceive (raw-message) (defun perceive (raw-message)
(let ((type (getf raw-message :type)) (payload (getf raw-message :payload))) (handler-case
(kernel-log "PERCEIVE: ~a (~a)" type (or (getf payload :sensor) "no-sensor")) (let ((type (getf raw-message :type)) (payload (getf raw-message :payload)))
(cond ((eq type :EVENT) (let ((sensor (getf payload :sensor))) (kernel-log "PERCEIVE: ~a (~a)" type (or (getf payload :sensor) "no-sensor"))
(case sensor (cond ((eq type :EVENT) (let ((sensor (getf payload :sensor)))
(:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast)))) (case sensor
(:point-update (let ((element (getf payload :element))) (when element (ingest-ast element)))) (:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast))))
(:interrupt (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t)))))) (:point-update (let ((element (getf payload :element))) (when element (ingest-ast element))))
((eq type :RESPONSE) (:interrupt (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t))))))
(kernel-log "ACT RESULT: ~a~%PAYLOAD: ~s~%" (getf payload :status) payload))) ((eq type :RESPONSE)
raw-message)) (kernel-log "ACT RESULT: ~a~%PAYLOAD: ~s~%" (getf payload :status) payload)))
raw-message)
(error (c)
(kernel-log "PERCEIVE ERROR: Malformed stimulus received: ~a" c)
nil)))
(defun start-heartbeat (&optional (interval 60)) (defun start-heartbeat (&optional (interval 60))
(setf *heartbeat-thread* (bt:make-thread (lambda () (loop (sleep interval) (kernel-log "KERNEL: Heartbeat pulse...") (setf *heartbeat-thread* (bt:make-thread (lambda () (loop (sleep interval) (kernel-log "KERNEL: Heartbeat pulse...")

55
src/protocol.lisp
View File

@@ -1,22 +1,53 @@
(in-package :org-agent) (in-package :org-agent)
(defun frame-message (msg-string) (defun frame-message (msg-string)
"Prefix MSG-STRING with a 6-character hex length (lowercase)." "Prefix MSG-STRING with a 6-character hex length (lowercase).
(let ((len (length msg-string))) FUTURE: Will also prefix a 64-char HMAC signature when OACP_ENFORCE_HMAC=true."
(format nil "~(~6,'0x~)~a" len msg-string))) (let ((len (length msg-string))
(enforce-hmac (uiop:getenv "OACP_ENFORCE_HMAC")))
(if (and enforce-hmac (string-equal enforce-hmac "true"))
(let* ((secret (or (uiop:getenv "OACP_HMAC_SECRET") "default-insecure-secret"))
(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 parse-message (framed-string) (defun parse-message (framed-string)
"Extract and parse the S-expression from a framed string." "Extract and parse the S-expression from a framed string, securely preventing reader macro injection."
(when (< (length framed-string) 6) (when (< (length framed-string) 6)
(error "Framed string too short")) (error "Framed string too short"))
(let* ((len-str (subseq framed-string 0 6)) (let* ((enforce-hmac (uiop:getenv "OACP_ENFORCE_HMAC"))
(actual-msg (subseq framed-string 6)) (use-hmac (and enforce-hmac (string-equal enforce-hmac "true")))
(expected-len (ignore-errors (parse-integer len-str :radix 16)))) (prefix-len (if use-hmac 70 6)))
(unless expected-len (when (< (length framed-string) prefix-len)
(error "Invalid hex length prefix: ~a" len-str)) (error "Framed string too short for OACP signature/length"))
(unless (= expected-len (length actual-msg))
(error "Message length mismatch. Expected ~a, got ~a" expected-len (length actual-msg))) (let* ((len-str (subseq framed-string 0 6))
(read-from-string actual-msg))) (signature (when use-hmac (subseq framed-string 6 70)))
(actual-msg (subseq framed-string prefix-len))
(expected-len (ignore-errors (parse-integer len-str :radix 16))))
(unless expected-len
(error "Invalid hex length prefix: ~a" len-str))
(unless (= expected-len (length actual-msg))
(error "Message length mismatch. Expected ~a, got ~a" expected-len (length actual-msg)))
;; HMAC Validation Foundation
(when use-hmac
(let* ((secret (or (uiop:getenv "OACP_HMAC_SECRET") "default-insecure-secret"))
(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 "OACP Integrity Failure: HMAC signature mismatch")))))
;; SECURITY: Prevent Reader Macro Injection (e.g. #. ) during deserialization
(let ((*read-eval* nil))
(read-from-string actual-msg)))))
(defun make-hello-message (version) (defun make-hello-message (version)
"Construct the standard HELLO handshake message." "Construct the standard HELLO handshake message."

6
src/skills.lisp
View File

@@ -128,17 +128,17 @@ EXAMPLES:
(setf finished :error)))) (setf finished :error))))
:name (format nil "loader-~a" (pathname-name filepath)))) :name (format nil "loader-~a" (pathname-name filepath))))
(start-time (get-internal-real-time)) (start-time (get-internal-real-time))
(timeout-units (* timeout-seconds internal-time-units-per-second))) (timeout-units (truncate (* timeout-seconds internal-time-units-per-second))))
(loop (loop
(when (eq finished t) (return :success)) (when (eq finished t) (return :success))
(when (eq finished :error) (return :error)) (when (eq finished :error) (return :error))
(unless (bt:thread-alive-p thread) (return :error)) (unless (bt:thread-alive-p thread) (return :error))
(when (> (- (get-internal-real-time) start-time) timeout-units) (when (> (- (get-internal-real-time) start-time) timeout-units)
(kernel-log "KERNEL: Timing out skill ~a..." (pathname-name filepath))
#+sbcl (sb-thread:terminate-thread thread) #+sbcl (sb-thread:terminate-thread thread)
#-sbcl (bt:destroy-thread thread) #-sbcl (bt:destroy-thread thread)
(kernel-log "KERNEL ERROR: Timeout loading skill ~a" (pathname-name filepath))
(return :timeout)) (return :timeout))
(sleep 0.1)))) (sleep 0.05))))
(defun load-skill-from-org (filepath) (defun load-skill-from-org (filepath)
(when (uiop:file-exists-p filepath) (when (uiop:file-exists-p filepath)