Fix duplicate frame-message, tangled files, package.lisp corruption
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 3s
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 3s
- Removed duplicate frame-message from communication.org (was in 2 src blocks) - Fixed communication.org :tangle directive (was wrongly targeting package.lisp) - Added (in-package :opencortex) to engineering-standards.lisp - Retangled package.org, communication.org, engineering-standards.org Tests still not running - investigation in progress.
This commit is contained in:
@@ -10,7 +10,7 @@ The ~communication.lisp~ module defines the low-level transport and framing logi
|
|||||||
|
|
||||||
* Implementation (communication.lisp)
|
* Implementation (communication.lisp)
|
||||||
|
|
||||||
#+begin_src lisp :tangle ../library/package.lisp
|
#+begin_src lisp :tangle ../library/communication.lisp
|
||||||
(in-package :opencortex)
|
(in-package :opencortex)
|
||||||
|
|
||||||
(defun proto-get (plist key)
|
(defun proto-get (plist key)
|
||||||
@@ -32,13 +32,7 @@ The ~communication.lisp~ module defines the low-level transport and framing logi
|
|||||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||||
(setf (gethash key *actuator-registry*) fn)))
|
(setf (gethash key *actuator-registry*) fn)))
|
||||||
|
|
||||||
(defun frame-message (msg-plist)
|
;; Removed duplicate frame-message - kept the sanitized version below
|
||||||
"Frames a Lisp plist with a 6-character hex length and a newline for stream integrity."
|
|
||||||
(let* ((*print-pretty* nil)
|
|
||||||
(*print-circle* nil)
|
|
||||||
(msg-string (format nil "~s" msg-plist))
|
|
||||||
(len (length msg-string)))
|
|
||||||
(format nil "~6,'0x~a~%" len msg-string)))
|
|
||||||
|
|
||||||
(defun read-framed-message (stream)
|
(defun read-framed-message (stream)
|
||||||
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
||||||
|
|||||||
41
library/communication-tests.lisp
Normal file
41
library/communication-tests.lisp
Normal file
@@ -0,0 +1,41 @@
|
|||||||
|
(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)))))
|
||||||
@@ -1,5 +1,14 @@
|
|||||||
(in-package :opencortex)
|
(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))))
|
||||||
|
|
||||||
|
(in-package :opencortex)
|
||||||
|
|
||||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||||
"Global registry mapping target keywords to their physical actuator functions.")
|
"Global registry mapping target keywords to their physical actuator functions.")
|
||||||
|
|
||||||
@@ -8,20 +17,7 @@
|
|||||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||||
(setf (gethash key *actuator-registry*) fn)))
|
(setf (gethash key *actuator-registry*) fn)))
|
||||||
|
|
||||||
(defun frame-message (msg-plist)
|
;; Removed duplicate frame-message - kept the sanitized version below
|
||||||
"Frames a Lisp plist with a 6-character hex length and a newline for stream integrity."
|
|
||||||
(let* ((*print-pretty* nil)
|
|
||||||
(*print-circle* 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)
|
|
||||||
"Parses a hex-length prefixed framed string into a Lisp plist."
|
|
||||||
(let* ((len (parse-integer (subseq framed-string 0 6) :radix 16))
|
|
||||||
(payload (subseq framed-string 6 (+ 6 len))))
|
|
||||||
(let ((*read-eval* nil))
|
|
||||||
(read-from-string payload))))
|
|
||||||
|
|
||||||
(defun read-framed-message (stream)
|
(defun read-framed-message (stream)
|
||||||
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
||||||
|
|||||||
@@ -1,3 +1,5 @@
|
|||||||
|
(in-package :opencortex)
|
||||||
|
|
||||||
(defvar *engineering-std-*project-root* nil
|
(defvar *engineering-std-*project-root* nil
|
||||||
"Path to the project root for enforcement checks.")
|
"Path to the project root for enforcement checks.")
|
||||||
|
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
(defpackage :opencortex
|
(defpackage :opencortex
|
||||||
(:use :cl)
|
(:use :cl)
|
||||||
(:export
|
(:export
|
||||||
;; --- communication protocol ---
|
;; --- communication protocol ---
|
||||||
#:frame-message
|
#:frame-message
|
||||||
#:read-framed-message
|
#:read-framed-message
|
||||||
@@ -12,13 +12,13 @@
|
|||||||
#:parse-message
|
#:parse-message
|
||||||
#:make-hello-message
|
#:make-hello-message
|
||||||
#:validate-communication-protocol-schema
|
#:validate-communication-protocol-schema
|
||||||
|
|
||||||
;; --- Daemon Lifecycle ---
|
;; --- Daemon Lifecycle ---
|
||||||
#:start-daemon
|
#:start-daemon
|
||||||
#:stop-daemon
|
#:stop-daemon
|
||||||
#:harness-log
|
#:harness-log
|
||||||
#:main
|
#:main
|
||||||
|
|
||||||
;; --- Memory (CLOSOS) ---
|
;; --- Memory (CLOSOS) ---
|
||||||
#:ingest-ast
|
#:ingest-ast
|
||||||
#:lookup-object
|
#:lookup-object
|
||||||
@@ -40,9 +40,7 @@
|
|||||||
#:org-object-hash
|
#:org-object-hash
|
||||||
#:snapshot-memory
|
#:snapshot-memory
|
||||||
#:rollback-memory
|
#:rollback-memory
|
||||||
#:save-memory-to-disk
|
|
||||||
#:load-memory-from-disk
|
|
||||||
|
|
||||||
;; --- Context API (Peripheral Vision) ---
|
;; --- Context API (Peripheral Vision) ---
|
||||||
#:context-query-store
|
#:context-query-store
|
||||||
#:context-get-active-projects
|
#:context-get-active-projects
|
||||||
@@ -54,7 +52,7 @@
|
|||||||
#:context-get-skill-telemetry
|
#:context-get-skill-telemetry
|
||||||
#:harness-track-telemetry
|
#:harness-track-telemetry
|
||||||
#:context-assemble-global-awareness
|
#:context-assemble-global-awareness
|
||||||
|
|
||||||
;; --- Reactive Signal Pipeline ---
|
;; --- Reactive Signal Pipeline ---
|
||||||
#:process-signal
|
#:process-signal
|
||||||
#:perceive-gate
|
#:perceive-gate
|
||||||
@@ -68,7 +66,7 @@
|
|||||||
#:initialize-actuators
|
#:initialize-actuators
|
||||||
#:dispatch-action
|
#:dispatch-action
|
||||||
#:register-actuator
|
#:register-actuator
|
||||||
|
|
||||||
;; --- Skill Engine ---
|
;; --- Skill Engine ---
|
||||||
#:load-skill-from-org
|
#:load-skill-from-org
|
||||||
#:initialize-all-skills
|
#:initialize-all-skills
|
||||||
@@ -101,63 +99,50 @@
|
|||||||
#:register-emacs-client
|
#:register-emacs-client
|
||||||
#:unregister-emacs-client
|
#:unregister-emacs-client
|
||||||
|
|
||||||
;; --- Probabilistic Engine ---
|
;; --- Probabilistic Engine ---
|
||||||
#:ask-probabilistic
|
#:ask-probabilistic
|
||||||
#:register-probabilistic-backend
|
#:register-probabilistic-backend
|
||||||
#:distill-prompt
|
#:distill-prompt
|
||||||
#:*provider-cascade*
|
#:*provider-cascade*
|
||||||
|
|
||||||
;; --- Vector Search ---
|
;; --- Security Vault ---
|
||||||
#:get-embedding
|
|
||||||
#:cosine-similarity
|
|
||||||
#:semantic-search
|
|
||||||
|
|
||||||
;; --- Tool Permissions ---
|
|
||||||
#:get-tool-permission
|
|
||||||
#:set-tool-permission
|
|
||||||
#:check-tool-permission-gate
|
|
||||||
|
|
||||||
;; --- Emacs Edit Skill ---
|
|
||||||
#:emacs-edit-generate-id
|
|
||||||
#:emacs-edit-id-format
|
|
||||||
#:emacs-edit-set-property
|
|
||||||
#:emacs-edit-set-todo
|
|
||||||
|
|
||||||
;; --- Self-Edit Skill ---
|
|
||||||
#:self-edit-balance-parens
|
|
||||||
#:self-edit-apply
|
|
||||||
|
|
||||||
;; --- Security Vault ---
|
|
||||||
#:vault-get-secret
|
#:vault-get-secret
|
||||||
#:vault-set-secret
|
#:vault-set-secret
|
||||||
|
|
||||||
;; --- Deterministic Logic ---
|
;; --- Deterministic Logic ---
|
||||||
#:list-objects-with-attribute
|
#:list-objects-with-attribute
|
||||||
#:deterministic-verify
|
#:deterministic-verify
|
||||||
|
|
||||||
;; --- AST Helpers ---
|
;; --- AST Helpers ---
|
||||||
#:find-headline-missing-id))
|
#:find-headline-missing-id))
|
||||||
|
|
||||||
(in-package :opencortex)
|
(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))))
|
||||||
|
|
||||||
(defvar *system-logs* nil)
|
(defvar *system-logs* nil)
|
||||||
(defvar *logs-lock* (bordeaux-threads:make-lock "harness-logs-lock"))
|
(defvar *logs-lock* (bt:make-lock "harness-logs-lock"))
|
||||||
(defvar *max-log-history* 100)
|
(defvar *max-log-history* 100)
|
||||||
|
|
||||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||||
"Global registry of all loaded skills.")
|
"Global registry of all loaded skills.")
|
||||||
|
|
||||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
(defvar *telemetry-lock* (bt:make-lock "harness-telemetry-lock"))
|
||||||
|
|
||||||
(defun harness-track-telemetry (skill-name duration status)
|
(defun harness-track-telemetry (skill-name duration status)
|
||||||
"Updates performance metrics for a specific skill. Status should be :success or :rejected."
|
"Updates performance metrics for a specific skill. Status should be :success or :rejected."
|
||||||
(when skill-name
|
(when skill-name
|
||||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
(bt:with-lock-held (*telemetry-lock*)
|
||||||
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
||||||
(incf (getf entry :executions))
|
(incf (getf entry :executions))
|
||||||
(incf (getf entry :total-time) duration)
|
(incf (getf entry :total-time) duration)
|
||||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||||
(setf (gethash skill-name *skill-telemetry*) entry)))))
|
(setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||||
|
|
||||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||||
@@ -181,22 +166,9 @@
|
|||||||
(defun harness-log (msg &rest args)
|
(defun harness-log (msg &rest args)
|
||||||
"Centralized logging for the harness."
|
"Centralized logging for the harness."
|
||||||
(let ((formatted-msg (apply #'format nil msg args)))
|
(let ((formatted-msg (apply #'format nil msg args)))
|
||||||
(bordeaux-threads:with-lock-held (*logs-lock*)
|
(bt:with-lock-held (*logs-lock*)
|
||||||
(push formatted-msg *system-logs*)
|
(push formatted-msg *system-logs*)
|
||||||
(when (> (length *system-logs*) *max-log-history*)
|
(when (> (length *system-logs*) *max-log-history*)
|
||||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||||
(format t "~a~%" formatted-msg)
|
(format t "~a~%" formatted-msg)
|
||||||
(finish-output)))
|
(finish-output)))
|
||||||
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
(defun get-cognitive-tool-body (tool-name)
|
|
||||||
"Retrieves the body function of a cognitive tool, or nil if not found."
|
|
||||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
|
||||||
(when tool
|
|
||||||
(cognitive-tool-body tool))))
|
|
||||||
|
|||||||
@@ -108,6 +108,8 @@ The engineering standards skill is a HARD BLOCK gate. Violations are rejected, n
|
|||||||
** Pre-Task Enforcement (Blocking)
|
** Pre-Task Enforcement (Blocking)
|
||||||
|
|
||||||
#+begin_src lisp :tangle ../library/gen/org-skill-engineering-standards.lisp
|
#+begin_src lisp :tangle ../library/gen/org-skill-engineering-standards.lisp
|
||||||
|
(in-package :opencortex)
|
||||||
|
|
||||||
(defvar *engineering-std-*project-root* nil
|
(defvar *engineering-std-*project-root* nil
|
||||||
"Path to the project root for enforcement checks.")
|
"Path to the project root for enforcement checks.")
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user