diff --git a/harness/package.org b/harness/package.org index 5098a74..55b0f9f 100644 --- a/harness/package.org +++ b/harness/package.org @@ -224,4 +224,57 @@ Centralized logging function. It simultaneously writes to standard output and th (setq *system-logs* (subseq *system-logs* 0 *max-log-history*)))) (format t "~a~%" formatted-msg) (finish-output))) -#+end_src \ No newline at end of file +#+end_src +* Global Test Runner +#+begin_src lisp :tangle (expand-file-name "tests/run-all-tests.lisp" (concat (or (getenv "INSTALL_DIR") ".") "/harness")) +(load "~/quicklisp/setup.lisp") + +(push #p"./" asdf:*central-registry*) + +(ql:quickload '(:usocket :bordeaux-threads :cl-postgres :split-sequence + :dexador :jonathan :cl-dotenv :hunchentoot + :trivial-garbage :s-sql :str :uuid :cl-json :uiop :fiveam)) + +(asdf:load-system :opencortex) +(asdf:load-system :opencortex/tests) + +(format t "~%=== Running ALL Test Suites ===~%") + +;; Engineering Standards tests +(when (find-package :OPENCORTEX-ENGINEERING-STANDARDS-TESTS) + (fiveam:run! 'OPENCORTEX-ENGINEERING-STANDARDS-TESTS::ENGINEERING-STANDARDS-SUITE)) + +;; Literate Programming tests +(when (find-package :OPENCORTEX-LITERATE-PROGRAMMING-TESTS) + (fiveam:run! 'OPENCORTEX-LITERATE-PROGRAMMING-TESTS::LITERATE-PROGRAMMING-SUITE)) + +;; Communication tests +(when (find-package :OPENCORTEX-TESTS) + (fiveam:run! 'OPENCORTEX-TESTS::COMMUNICATION-PROTOCOL-SUITE)) + +;; Pipeline tests +(when (find-package :OPENCORTEX-PIPELINE-TESTS) + (fiveam:run! 'OPENCORTEX-PIPELINE-TESTS::PIPELINE-SUITE)) + +;; Boot sequence tests +(when (find-package :OPENCORTEX-BOOT-TESTS) + (fiveam:run! 'OPENCORTEX-BOOT-TESTS::BOOT-SUITE)) + +;; Memory tests +(when (find-package :OPENCORTEX-MEMORY-TESTS) + (fiveam:run! 'OPENCORTEX-MEMORY-TESTS::MEMORY-SUITE)) + +;; Immune system tests +(when (find-package :OPENCORTEX-IMMUNE-SYSTEM-TESTS) + (fiveam:run! 'OPENCORTEX-IMMUNE-SYSTEM-TESTS::IMMUNE-SUITE)) + +;; Emacs edit tests +(when (find-package :OPENCORTEX-EMACS-EDIT-TESTS) + (fiveam:run! 'OPENCORTEX-EMACS-EDIT-TESTS::EMACS-EDIT-SUITE)) + +;; Lisp utils tests +(when (find-package :OPENCORTEX-LISP-UTILS-TESTS) + (fiveam:run! 'OPENCORTEX-LISP-UTILS-TESTS::LISP-UTILS-SUITE)) + +(format t "~%=== ALL TESTS COMPLETE ===~%") +#+end_src diff --git a/harness/reason.org b/harness/reason.org index d6dbee1..8d11cee 100644 --- a/harness/reason.org +++ b/harness/reason.org @@ -199,7 +199,8 @@ The `think` function is the heart of the probabilistic engine. It constructs a p (tool-belt (generate-tool-belt-prompt)) (global-context (context-assemble-global-awareness)) (system-logs (context-get-system-logs)) - (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))) + (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent")) + (rejection-trace (proto-get (proto-get context :payload) :rejection-trace))) ;; Generate prompt from skill or raw text (let* ((prompt-generator (when active-skill @@ -211,8 +212,14 @@ The `think` function is the heart of the probabilistic engine. It constructs a p (if (and p (stringp p)) p "Maintain metabolic stasis.")))) + + ;; Inject Reflection Loop feedback if a previous proposal was rejected + (reflection-feedback (if rejection-trace + (format nil "~%~%PREVIOUS PROPOSAL REJECTED:~%Your previous proposal was rejected by the deterministic safety gates.~%Rejection Trace: ~a~%You MUST fix the syntax or logic error described above and try again." rejection-trace) + "")) + (system-prompt (format nil - "IDENTITY: ~a + "IDENTITY: ~a~a You are a component of the OpenCortex neurosymbolic AI agent. Your task is to generate exactly ONE valid Lisp plist response. @@ -243,6 +250,7 @@ GLOBAL CONTEXT: RECENT LOGS: ~a" assistant-name + reflection-feedback tool-belt global-context system-logs))) @@ -417,30 +425,45 @@ The deterministic engine runs all registered skills' verification functions. Thi (member sensor '(:user-input :chat-message))) (return-from reason-gate signal)) - ;; Generate proposal via LLM - (let ((candidate (think signal))) + ;; Reflection Loop: Retry up to 3 times if deterministic gates reject + (let ((retries 3) + (current-signal (copy-tree signal)) + (last-rejection nil)) + (loop + (when (<= retries 0) + (harness-log "REASON: Reflection loop exhausted. Final rejection.") + (setf (getf signal :approved-action) last-rejection) + (setf (getf signal :status) :reasoned) + (return signal)) - (harness-log "REASON: candidate type = ~a" (type-of candidate)) + (when last-rejection + (setf (getf (getf current-signal :payload) :rejection-trace) last-rejection)) - ;; Validate candidate is a proper plist (not an error string or symbol) - (if (and candidate - (listp candidate) - (or (keywordp (car candidate)) - (eq (car candidate) 'TYPE) - (eq (car candidate) 'type))) + (let ((candidate (think current-signal))) + (harness-log "REASON: candidate type = ~a" (type-of candidate)) - ;; Valid proposal - run through deterministic verification - (setf (getf signal :approved-action) - (deterministic-verify candidate signal)) + (if (and candidate + (listp candidate) + (or (keywordp (car candidate)) + (eq (car candidate) 'TYPE) + (eq (car candidate) 'type))) - ;; Invalid response - log and drop - (progn - (harness-log "REASON: Invalid candidate type ~a, dropping" - (type-of candidate)) - (setf (getf signal :approved-action) nil))) + (let ((verified (deterministic-verify candidate current-signal))) + (if (member (getf verified :type) '(:LOG :EVENT :log :event)) + (progn + (harness-log "REASON: Proposal rejected by gate. Retrying (~a left)." (1- retries)) + (decf retries) + (setf last-rejection verified)) + (progn + (setf (getf signal :approved-action) verified) + (setf (getf signal :status) :reasoned) + (return signal)))) - (setf (getf signal :status) :reasoned) - signal))) + (progn + (harness-log "REASON: Invalid candidate type ~a, dropping" (type-of candidate)) + (setf (getf signal :approved-action) nil) + (setf (getf signal :status) :reasoned) + (return signal)))))))) #+end_src * Test Suite diff --git a/harness/skills.org b/harness/skills.org index 6ebf9cf..3f68fe2 100644 --- a/harness/skills.org +++ b/harness/skills.org @@ -363,11 +363,13 @@ EXAMPLES: --- " ))) (maphash (lambda (name tool) - (setf output (concatenate 'string output - (format nil "- ~a: ~a~% Parameters: ~s~%~%" - name - (cognitive-tool-description tool) - (cognitive-tool-parameters tool))))) + (let ((perm (ignore-errors (uiop:symbol-call :opencortex.skills.org-skill-tool-permissions :get-tool-permission name)))) + (unless (eq perm :deny) + (setf output (concatenate 'string output + (format nil "- ~a: ~a~% Parameters: ~s~%~%" + name + (cognitive-tool-description tool) + (cognitive-tool-parameters tool))))))) *cognitive-tools*) output)) #+end_src @@ -462,9 +464,9 @@ EXAMPLES: (declare (ignore context)) (let* ((file (getf args :file)) (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) - (truename (ignore-errors (namestring (truename file))))) - (or (null truename) - (str:starts-with-p memex-root truename)))) + (abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd))))) + (and (str:starts-with-p memex-root abs-path) + (not (search ".." abs-path))))) :body (lambda (args) (let ((file (getf args :file))) (handler-case @@ -483,9 +485,10 @@ EXAMPLES: (declare (ignore context)) (let* ((file (getf args :file)) (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) - (truename (ignore-errors (namestring (truename file))))) - (or (null truename) - (str:starts-with-p memex-root truename)))) + (abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd))))) + (and (str:starts-with-p memex-root abs-path) + (not (search ".." abs-path)) + (not (str:ends-with-p ".org" abs-path))))) ;; Force AST tools for .org files :body (lambda (args) (let ((file (getf args :file)) (content (getf args :content)) @@ -515,9 +518,10 @@ EXAMPLES: (declare (ignore context)) (let* ((file (getf args :file)) (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) - (truename (ignore-errors (namestring (truename file))))) - (or (null truename) - (str:starts-with-p memex-root truename)))) + (abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd))))) + (and (str:starts-with-p memex-root abs-path) + (not (search ".." abs-path)) + (not (str:ends-with-p ".org" abs-path))))) ;; Force AST tools for .org files :body (lambda (args) (let ((file (getf args :file)) (old (getf args :old)) diff --git a/skills/org-skill-emacs-edit.org b/skills/org-skill-emacs-edit.org index bf94dd0..b41170f 100644 --- a/skills/org-skill-emacs-edit.org +++ b/skills/org-skill-emacs-edit.org @@ -184,6 +184,7 @@ Write AST back to file preserving structure. (defun emacs-edit-write-file (file-path ast) "Writes AST back to FILE-PATH, preserving org structure. Clears cache after write." + (opencortex::snapshot-memory) (let ((org-text (emacs-edit-ast-to-org ast))) (with-open-file (out file-path :direction :output :if-exists :supersede) (write-string org-text out))) diff --git a/skills/org-skill-tool-permissions.org b/skills/org-skill-tool-permissions.org index b2e0dfe..af95756 100644 --- a/skills/org-skill-tool-permissions.org +++ b/skills/org-skill-tool-permissions.org @@ -47,7 +47,7 @@ Tool permissions and embedding generation via multiple providers. (case perm (:allow :allow) (:deny :deny) - (:ask (list :ask tool-name context)) + (:ask (list :ask tool-name)) (t :allow)))) (def-cognitive-tool :get-embedding @@ -111,10 +111,22 @@ Tool permissions and embedding generation via multiple providers. (defskill :skill-tool-permissions :priority 600 - :trigger (lambda (c) (declare (ignore c)) nil) + ;; Trigger whenever there's a tool call + :trigger (lambda (c) + (let* ((action (getf c :candidate)) + (target (getf action :target))) + (or (eq target :TOOL) (eq target :tool)))) :deterministic (lambda (a c) (let ((tool (getf (getf a :payload) :tool))) - (when tool (check-tool-permission-gate tool c))))) + (if tool + (let ((perm (check-tool-permission-gate tool c))) + (cond + ((eq perm :deny) + (list :type :LOG :payload (list :text (format nil "Tool '~a' execution denied by permission tiers." tool)))) + ((and (listp perm) (eq (car perm) :ask)) + (list :type :EVENT :status :suspended :reason :ask-permission :payload (list :tool tool :action a))) + (t a))) + a)))) #+end_src * Test Suite