feat: Add Lisp Validator skill with 3-phase deterministic gate
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 5s
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 5s
- Implements structural (O(n) paren balance), syntactic (reader with *read-eval* nil), and semantic (whitelist AST walk) validation. - Exposes :validate-lisp cognitive tool for Probabilistic Engine self-correction. - Replaces validate-lisp-syntax stub in harness/skills.org with delegation. - Adds mandatory validation rule to Probabilistic Engine system prompt. - Refactors org-skill-policy.org with 6 concrete invariants (Transparency, Autonomy, Zero-Bloat, Modularity, Mentorship, Sustainability) and explicit override hierarchy. - Adds Harness Boundary Contract to harness/manifest.org.
This commit is contained in:
@@ -81,3 +81,16 @@ This system defines the native Croatoan TUI client.
|
||||
:depends-on (:opencortex :croatoan :usocket :bordeaux-threads)
|
||||
:components ((:file "library/tui-client")))
|
||||
#+end_src
|
||||
|
||||
* The Harness Boundary Contract
|
||||
The harness is the minimal, unbreakable core of OpenCortex. It consists of the literate source files that define the kernel and the system manifest. Any proposed modification to these files must be justified, because the harness is the system's immune system and must never grow fat.
|
||||
|
||||
** Primary Boundary Files
|
||||
- ~harness/*.org~ — The literate source of truth for all kernel modules.
|
||||
- ~opencortex.asd~ — The ASDF system manifest.
|
||||
|
||||
** Generated Artifacts (NOT Primary Boundary)
|
||||
The files in ~library/*.lisp~ are derivative artifacts produced by tangling the harness Org files. They are NOT primary boundary files; modifying them directly violates the Engineering Standard of Literate-Only Modification. Any change to the harness must be made in the corresponding Org file and then tangled.
|
||||
|
||||
** Enforcement
|
||||
The Policy skill's ~*modularity-protected-paths*~ variable guards the primary boundary locations by default. Any agent action that proposes to modify a file within these paths must include a ~:modularity-justification~ field explaining why the change cannot be implemented as a skill.
|
||||
|
||||
@@ -72,12 +72,14 @@ The Reason stage is the cognitive engine of the OpenCortex. It bridges the gap b
|
||||
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
||||
(system-prompt (format nil "IDENTITY: ~a. MANDATE: Respond with ONE Lisp plist. ~a ~a RECENT_LOGS: ~a
|
||||
IMPORTANT: To reply to the user, you MUST use:
|
||||
(:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"<Response Text>\"))
|
||||
(:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT "<Response Text>"))
|
||||
|
||||
To call a tool, you MUST use:
|
||||
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL \"<name>\" :ARGS (:arg1 \"val\"))
|
||||
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL "<name>" :ARGS (:arg1 "val"))
|
||||
|
||||
PROVIDER RULE: Always use the default cascade provider unless a specific model or capability is required for the task."
|
||||
MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete, you MUST call the `:validate-lisp` tool with the proposed code. If the tool returns `:status :error`, read the `:reason` and `:failed` fields, fix the defect, and re-validate. You are strictly forbidden from relying on your own paren-balancing or syntax intuition.
|
||||
|
||||
PROVIDER RULE: Always use the default cascade provider unless a specific model or capability is required for the task."
|
||||
assistant-name global-context tool-belt system-logs)))
|
||||
(let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (strip-markdown thought))
|
||||
|
||||
@@ -131,13 +131,14 @@ A static, hardcoded architecture is inherently fragile. The ~opencortex~ Skill E
|
||||
** Jailed Loading (load-skill-from-org)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid, readable Common Lisp forms."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof))
|
||||
(values t nil)))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
"Checks if a string contains valid, readable Common Lisp forms.
|
||||
Delegates to the Lisp Validator skill for structural + syntactic validation."
|
||||
(let* ((result (lisp-validator-validate code-string :strict nil))
|
||||
(status (getf result :status))
|
||||
(reason (getf result :reason)))
|
||||
(if (eq status :success)
|
||||
(values t nil)
|
||||
(values nil (or reason "Lisp Validator rejected code.")))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file into a jailed package."
|
||||
|
||||
231
library/gen/org-skill-lisp-validator.lisp
Normal file
231
library/gen/org-skill-lisp-validator.lisp
Normal file
@@ -0,0 +1,231 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun lisp-validator-check-structural (code-string)
|
||||
"Checks for balanced parens, brackets, and terminated strings.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil reason-string line col)."
|
||||
(let ((stack nil)
|
||||
(in-string nil)
|
||||
(escaped nil)
|
||||
(line 1)
|
||||
(col 0)
|
||||
(last-open-line 1)
|
||||
(last-open-col 0))
|
||||
(dotimes (i (length code-string)
|
||||
(if (null stack)
|
||||
(values t nil nil nil)
|
||||
(values nil (format nil "Unbalanced '~a' opened at line ~a, col ~a"
|
||||
(caar stack) last-open-line last-open-col)
|
||||
last-open-line last-open-col)))
|
||||
(let ((ch (char code-string i)))
|
||||
(cond (escaped (setf escaped nil))
|
||||
((char= ch #\\) (setf escaped t))
|
||||
(in-string
|
||||
(when (char= ch #\") (setf in-string nil)))
|
||||
((char= ch #\;)
|
||||
;; Skip to end of line
|
||||
(loop while (and (< i (1- (length code-string)))
|
||||
(not (char= (char code-string (1+ i)) #\Newline)))
|
||||
do (incf i))
|
||||
(incf line) (setf col 0))
|
||||
((char= ch #\")
|
||||
(setf in-string t))
|
||||
((member ch '(#\( #\[))
|
||||
(push (list (string ch) line col) stack)
|
||||
(setf last-open-line line last-open-col col))
|
||||
((char= ch #\))
|
||||
(cond ((null stack)
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Unexpected ')' at line ~a, col ~a" line col) line col)))
|
||||
((string= (caar stack) "[")
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Mismatched ']' expected at line ~a, col ~a" line col) line col)))
|
||||
(t (pop stack))))
|
||||
((char= ch #\])
|
||||
(cond ((null stack)
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Unexpected ']' at line ~a, col ~a" line col) line col)))
|
||||
((string= (caar stack) "(")
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Mismatched ')' expected at line ~a, col ~a" line col) line col)))
|
||||
(t (pop stack))))
|
||||
((char= ch #\Newline)
|
||||
(incf line) (setf col 0)))
|
||||
(unless (char= ch #\Newline) (incf col))))))
|
||||
|
||||
(defun lisp-validator-check-syntactic (code-string)
|
||||
"Checks if the code can be read by SBCL with *read-eval* nil.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil error-message line col)."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof)))
|
||||
(values t nil nil nil))
|
||||
(error (c)
|
||||
(let ((msg (format nil "~a" c)))
|
||||
(values nil msg nil nil)))))
|
||||
|
||||
(defparameter *lisp-validator-whitelist*
|
||||
'(;; Math & Logic
|
||||
+ - * / = < > <= >= 1+ 1- min max mod abs floor ceiling round
|
||||
and or not null eq eql equal string= string-equal char= char-equal
|
||||
;; List Manipulation
|
||||
list cons car cdr cadr cddr cdar caar caddr cdddr append mapcar remove-if remove-if-not
|
||||
length reverse sort nth nthcdr push pop last butlast subseq
|
||||
;; Plists, Alists, and Hash Tables
|
||||
getf gethash assoc acons pairlis rassoc
|
||||
;; Control Flow
|
||||
let let* if cond when unless case typecase prog1 progn
|
||||
;; Strings
|
||||
format concatenate string-downcase string-upcase search subseq replace
|
||||
;; Type predicates
|
||||
stringp numberp integerp listp symbolp keywordp null
|
||||
;; Kernel safe symbols
|
||||
opencortex::harness-log
|
||||
opencortex::snapshot-memory opencortex::rollback-memory
|
||||
opencortex::lookup-object opencortex::list-objects-by-type
|
||||
opencortex::ingest-ast opencortex::find-headline-missing-id
|
||||
opencortex::context-query-store opencortex::context-get-active-projects
|
||||
opencortex::context-get-recent-completed-tasks opencortex::context-list-all-skills
|
||||
opencortex::context-get-system-logs opencortex::context-assemble-global-awareness
|
||||
opencortex::org-object-id opencortex::org-object-type opencortex::org-object-attributes
|
||||
opencortex::org-object-content opencortex::org-object-parent-id
|
||||
opencortex::org-object-children opencortex::org-object-version
|
||||
opencortex::org-object-last-sync opencortex::org-object-hash
|
||||
opencortex::org-object-vector
|
||||
;; Essential macros and special operators
|
||||
declare ignore quote function lambda defun defvar defparameter defmacro
|
||||
;; Safe I/O
|
||||
with-open-file write-string read-line
|
||||
;; Package introspection
|
||||
find-package make-package in-package do-external-symbols find-symbol
|
||||
;; Safe system interaction
|
||||
uiop:run-program uiop:getenv uiop:merge-pathnames* uiop:file-exists-p
|
||||
uiop:directory-exists-p uiop:read-file-string uiop:split-string
|
||||
;; Time
|
||||
get-universal-time get-internal-real-time sleep
|
||||
;; Equality
|
||||
equalp = equal eq eql))
|
||||
"Static whitelist of symbols permitted in the Lisp Validator sandbox."
|
||||
|
||||
(defvar *lisp-validator-registry* nil
|
||||
"List of dynamically registered safe symbols.")
|
||||
|
||||
(defun lisp-validator-register (symbols)
|
||||
"Adds symbols to the global validator registry."
|
||||
(setf *lisp-validator-registry*
|
||||
(append *lisp-validator-registry*
|
||||
(if (listp symbols) symbols (list symbols))))
|
||||
(harness-log "LISP VALIDATOR: Registered ~a new safe symbols."
|
||||
(length (if (listp symbols) symbols (list symbols)))))
|
||||
|
||||
(defun lisp-validator-is-safe (symbol)
|
||||
"Checks if a symbol is in the static whitelist or the dynamic registry."
|
||||
(or (member symbol *lisp-validator-whitelist* :test #'string-equal)
|
||||
(member symbol *lisp-validator-registry* :test #'string-equal)))
|
||||
|
||||
(defun lisp-validator-ast-walk (form)
|
||||
"Recursively walks the Lisp AST. Returns T if safe, NIL if unsafe."
|
||||
(cond
|
||||
;; Self-evaluating objects are safe.
|
||||
((or (stringp form) (numberp form) (keywordp form) (characterp form)) t)
|
||||
;; Symbols used as variables (in non-function position)
|
||||
((symbolp form) (lisp-validator-is-safe form))
|
||||
;; Lists represent function calls or special forms.
|
||||
((listp form)
|
||||
(let ((head (car form)))
|
||||
(cond
|
||||
((eq head 'quote) t)
|
||||
((not (symbolp head)) nil)
|
||||
((lisp-validator-is-safe head)
|
||||
(every #'lisp-validator-ast-walk (cdr form)))
|
||||
(t
|
||||
(harness-log "LISP VALIDATOR: Blocked call to non-whitelisted function ~a" head)
|
||||
nil))))
|
||||
(t nil)))
|
||||
|
||||
(defun lisp-validator-check-semantic (code-string)
|
||||
"Checks if all symbols in CODE-STRING are whitelisted.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil reason-string nil nil)."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof)
|
||||
until (eq form :eof)
|
||||
do (unless (lisp-validator-ast-walk form)
|
||||
(return-from lisp-validator-check-semantic
|
||||
(values nil "Code contains non-whitelisted symbols." nil nil)))))
|
||||
(values t nil nil nil))
|
||||
(error (c)
|
||||
(values nil (format nil "Semantic check failed: ~a" c) nil nil))))
|
||||
|
||||
(defun lisp-validator-validate (code-string &key strict)
|
||||
"Validates Lisp code through structural, syntactic, and optional semantic checks.
|
||||
Returns a plist:
|
||||
(:status :success :checks (:structural t :syntactic t :semantic t))
|
||||
or
|
||||
(:status :error :failed <check-key> :reason <string> :line <n> :col <n>)
|
||||
|
||||
When STRICT is non-nil, the semantic whitelist check is enforced.
|
||||
When STRICT is nil, semantic check is skipped for general validation."
|
||||
(let ((structural-ok nil) (syntactic-ok nil) (semantic-ok nil)
|
||||
(reason nil) (line nil) (col nil))
|
||||
;; Phase 1: Structural
|
||||
(multiple-value-setq (structural-ok reason line col)
|
||||
(lisp-validator-check-structural code-string))
|
||||
(unless structural-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :structural :reason reason :line line :col col)))
|
||||
;; Phase 2: Syntactic
|
||||
(multiple-value-setq (syntactic-ok reason line col)
|
||||
(lisp-validator-check-syntactic code-string))
|
||||
(unless syntactic-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :syntactic :reason reason :line line :col col)))
|
||||
;; Phase 3: Semantic (only when strict)
|
||||
(when strict
|
||||
(multiple-value-setq (semantic-ok reason line col)
|
||||
(lisp-validator-check-semantic code-string))
|
||||
(unless semantic-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :semantic :reason reason :line line :col col))))
|
||||
;; All clear
|
||||
(list :status :success
|
||||
:checks (list :structural t :syntactic t :semantic (or (not strict) semantic-ok)))))
|
||||
|
||||
(def-cognitive-tool :validate-lisp
|
||||
"Deterministically validates Lisp code for structural, syntactic, and semantic correctness.
|
||||
Use this BEFORE declaring any Lisp code edit complete."
|
||||
((:code :type :string :description "The Lisp code string to validate.")
|
||||
(:strict :type :boolean :description "If non-nil, enforces the semantic whitelist."))
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code))
|
||||
(strict (getf args :strict)))
|
||||
(if (and code (stringp code))
|
||||
(lisp-validator-validate code :strict strict)
|
||||
(list :status :error :reason "Missing :code argument.")))))
|
||||
|
||||
(defskill :skill-lisp-validator
|
||||
:priority 900
|
||||
:trigger (lambda (ctx)
|
||||
;; Trigger on any eval or shell action, or when validation is explicitly requested
|
||||
(let ((candidate (getf ctx :approved-action)))
|
||||
(when candidate
|
||||
(let ((payload (getf candidate :payload)))
|
||||
(member (getf payload :action) '(:eval :shell))))))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(let ((payload (getf action :payload)))
|
||||
(if (eq (getf payload :action) :eval)
|
||||
(let* ((code (getf payload :code))
|
||||
(result (lisp-validator-validate code :strict t)))
|
||||
(if (eq (getf result :status) :error)
|
||||
(progn
|
||||
(harness-log "LISP VALIDATOR: Blocked unsafe :eval action. ~a"
|
||||
(getf result :reason))
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "LISP VALIDATOR: Blocked unsafe eval. ~a"
|
||||
(getf result :reason)))))
|
||||
action))
|
||||
action))))
|
||||
@@ -1,25 +1,225 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun policy-check-autonomy (action context)
|
||||
"Ensures the action does not violate the Autonomy invariant."
|
||||
(defvar *policy-invariant-priorities*
|
||||
'((:transparency . 500)
|
||||
(:autonomy . 400)
|
||||
(:bloat . 300)
|
||||
(:modularity . 250)
|
||||
(:mentorship . 200)
|
||||
(:sustainability . 100))
|
||||
"Priority alist for policy invariant conflict resolution.
|
||||
Higher numbers take precedence.")
|
||||
|
||||
(defun policy-check-transparency (action context)
|
||||
"Ensures the action is inspectable and user-facing actions carry an explanation.
|
||||
Returns the action if clean, or a blocking LOG event if the action is opaque."
|
||||
(declare (ignore context))
|
||||
;; Implementation placeholder: currently permits all actions.
|
||||
;; Future: Scan for non-autonomous domain names or proprietary API endpoints.
|
||||
action)
|
||||
(unless (listp action)
|
||||
(return-from policy-check-transparency
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Transparency]: Action is not a valid plist. Rejected."))))
|
||||
(let* ((payload (getf action :payload))
|
||||
(target (or (getf action :target) (getf action :TARGET)))
|
||||
(explanation (or (getf payload :explanation) (getf payload :EXPLANATION)
|
||||
(getf payload :rationale) (getf payload :RATIONALE))))
|
||||
;; User-facing actions (CLI, TUI, Emacs) must explain themselves
|
||||
(when (and (member target '(:cli :tui :emacs :EMACS :CLI :TUI))
|
||||
(not explanation)
|
||||
(not (member (getf payload :action)
|
||||
'(:handshake :heartbeat :status-update))))
|
||||
(return-from policy-check-transparency
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Transparency]: User-facing action missing :explanation. Blocked."))))
|
||||
action))
|
||||
|
||||
(defvar *proprietary-domain-watchlist*
|
||||
'("googleapis.com" "api.openai.com" "anthropic.com" "api.groq.com" "openrouter.ai")
|
||||
"Domains that represent centralized, proprietary control.
|
||||
Actions targeting these are logged as autonomy debt, not hard-blocked,
|
||||
because tactical gateway usage is permitted under the strategic mandate.")
|
||||
|
||||
(defun policy-scan-proprietary-references (action)
|
||||
"Scans ACTION text fields for proprietary domain references.
|
||||
Returns the first matched domain, or NIL if clean."
|
||||
(let* ((payload (getf action :payload))
|
||||
(text (or (getf payload :text) (getf payload :TEXT) ""))
|
||||
(cmd (or (getf payload :cmd) (getf payload :CMD)
|
||||
(when (equal (getf payload :tool) "shell")
|
||||
(getf (getf payload :args) :cmd))
|
||||
""))
|
||||
(haystack (concatenate 'string text cmd)))
|
||||
(dolist (domain *proprietary-domain-watchlist* nil)
|
||||
(when (search domain haystack)
|
||||
(return domain)))))
|
||||
|
||||
(defun policy-check-autonomy (action context)
|
||||
"Flags actions that reference proprietary domains. Returns the action
|
||||
with an autonomy debt log appended, or the action itself if clean."
|
||||
(declare (ignore context))
|
||||
(let ((domain (policy-scan-proprietary-references action)))
|
||||
(if domain
|
||||
(progn
|
||||
(harness-log "POLICY [Autonomy]: Detected proprietary reference '~a'. Flagged for replacement." domain)
|
||||
;; Return a side-effect log but DO NOT block the action
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Autonomy Debt: Action references proprietary domain '~a'. Consider a local alternative." domain)
|
||||
:original-action action)))
|
||||
action)))
|
||||
|
||||
(defvar *policy-max-skill-size-chars* 50000
|
||||
"Maximum recommended size for a skill file tangled from an Org note.")
|
||||
|
||||
(defun policy-check-bloat (action context)
|
||||
"Warns if a :create-skill action exceeds the bloat threshold.
|
||||
Does not block, because size alone is not a proof of complexity."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(act (getf payload :action))
|
||||
(content (getf payload :content)))
|
||||
(when (and (eq act :create-skill)
|
||||
(stringp content)
|
||||
(> (length content) *policy-max-skill-size-chars*))
|
||||
(harness-log "POLICY [Bloat]: Proposed skill is ~a chars. Exceeds ~a char threshold."
|
||||
(length content) *policy-max-skill-size-chars*)
|
||||
(return-from policy-check-bloat
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Bloat Warning: Proposed skill (~a chars) exceeds ~a char threshold. Review for earned complexity."
|
||||
(length content) *policy-max-skill-size-chars*)
|
||||
:original-action action))))
|
||||
action))
|
||||
|
||||
(defvar *mentorship-required-actions*
|
||||
'(:create-skill :eval :modify-file :write-file :replace :rename-file :delete-file :shell :create-note)
|
||||
"Actions that trigger the Mentorship invariant.")
|
||||
|
||||
(defun policy-check-mentorship (action context)
|
||||
"Blocks high-impact actions that lack a mentorship note."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(act (or (getf payload :action) (getf action :action)))
|
||||
(note (or (getf payload :mentorship-note) (getf payload :MENTORSHIP-NOTE)))
|
||||
(target (or (getf action :target) (getf action :TARGET)))
|
||||
(tool (when (eq target :tool) (getf payload :tool))))
|
||||
(when (or (member act *mentorship-required-actions*)
|
||||
(member tool '("shell" "eval" "repair-file")))
|
||||
(unless note
|
||||
(return-from policy-check-mentorship
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Mentorship]: High-impact action missing :mentorship-note. Explain what you are doing and why. Blocked.")))))
|
||||
action))
|
||||
|
||||
(defvar *cloud-only-backends* '(:openrouter :openai :anthropic :groq :gemini-api)
|
||||
"Backends that require an internet connection and external infrastructure.")
|
||||
|
||||
(defun policy-check-sustainability (action context)
|
||||
"Logs sustainability debt when the action relies on cloud-only infrastructure.
|
||||
Does not block, because tactical cloud usage is permitted."
|
||||
(let* ((payload (getf context :payload))
|
||||
(backend (getf payload :backend))
|
||||
(provider (getf payload :provider)))
|
||||
(when (or (member backend *cloud-only-backends*)
|
||||
(member provider *cloud-only-backends*))
|
||||
(harness-log "POLICY [Sustainability]: Cloud provider '~a' used. Logged as sustainability debt."
|
||||
(or backend provider))
|
||||
(return-from policy-check-sustainability
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Sustainability Debt: Reliance on cloud provider '~a'. Consider Ollama or local inference."
|
||||
(or backend provider))))))
|
||||
action))
|
||||
|
||||
(defvar *modularity-protected-paths*
|
||||
'("harness/" "opencortex.asd")
|
||||
"Paths that constitute the unbreakable core of the system.
|
||||
Any action targeting these paths must include a :modularity-justification.
|
||||
This list is project-specific and should be configured at boot time.")
|
||||
|
||||
(defun policy-check-modularity (action context)
|
||||
"Blocks modifications to the system's protected core unless justified."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(target-file (or (getf payload :file) (getf payload :filename)))
|
||||
(justification (or (getf payload :modularity-justification)
|
||||
(getf payload :MODULARITY-JUSTIFICATION))))
|
||||
(when (and target-file
|
||||
(some (lambda (path) (search path target-file)) *modularity-protected-paths*)
|
||||
(not justification))
|
||||
(return-from policy-check-modularity
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Modularity]: Modification to protected core path blocked. Provide :modularity-justification explaining why this cannot be a skill."
|
||||
:blocked-path target-file))))
|
||||
action))
|
||||
|
||||
(defun policy-explain (invariant-key message &optional original-action)
|
||||
"Formats a policy decision into an auditable explanation plist.
|
||||
INVARIANT-KEY is one of :transparency, :autonomy, :bloat, :modularity, :mentorship, :sustainability.
|
||||
MESSAGE is a human-readable string.
|
||||
ORIGINAL-ACTION is the action that was blocked or modified."
|
||||
(list :type :REQUEST
|
||||
:target (or (ignore-errors (getf (getf original-action :meta) :source)) :cli)
|
||||
:payload (list :action :message
|
||||
:text (format nil "[POLICY ~a] ~a" invariant-key message)
|
||||
:explanation (format nil "Invariant: ~a | Rationale: ~a" invariant-key message)
|
||||
:original-action original-action)))
|
||||
|
||||
(defun policy-run-invariant-checks (action context)
|
||||
"Runs all invariant checks in priority order. Returns the final action,
|
||||
a blocking LOG event, or a warning wrapper."
|
||||
(let ((checks '(policy-check-transparency
|
||||
policy-check-autonomy
|
||||
policy-check-bloat
|
||||
policy-check-modularity
|
||||
policy-check-mentorship
|
||||
policy-check-sustainability)))
|
||||
(dolist (check-fn checks action)
|
||||
(let ((result (funcall check-fn action context)))
|
||||
;; If the check returned a LOG event, treat it as a block/warning
|
||||
(when (and (listp result)
|
||||
(member (getf result :type) '(:LOG :EVENT)))
|
||||
(let ((level (getf (getf result :payload) :level)))
|
||||
(cond ((eq level :error)
|
||||
;; Hard block: return the log event directly
|
||||
(return-from policy-run-invariant-checks result))
|
||||
(t
|
||||
;; Warning: log it, but continue with the original action
|
||||
(harness-log "~a" (getf (getf result :payload) :text))))))))))
|
||||
|
||||
(defun policy-find-engineering-standards-gate ()
|
||||
"Searches for the Engineering Standards gate across known jailed package names.
|
||||
Returns the function symbol, or NIL if unavailable."
|
||||
(dolist (pkg-name '(:opencortex.skills.org-skill-engineering-standards
|
||||
:opencortex.skills.org-skill-engineering
|
||||
:opencortex.skills.engineering-standards)
|
||||
nil)
|
||||
(let ((pkg (find-package pkg-name)))
|
||||
(when pkg
|
||||
(let ((sym (find-symbol "ENGINEERING-STANDARDS-GATE" pkg)))
|
||||
(when (and sym (fboundp sym))
|
||||
(return (symbol-function sym))))))))
|
||||
|
||||
(defun policy-deterministic-gate (action context)
|
||||
"The main policy gate. Sub-calls engineering standards if available."
|
||||
(let ((current-action (policy-check-autonomy action context)))
|
||||
(when current-action
|
||||
(let ((eng-pkg (find-package :opencortex.skills.org-skill-engineering-standards)))
|
||||
(when eng-pkg
|
||||
(let ((eng-gate (find-symbol "ENGINEERING-STANDARDS-GATE" eng-pkg)))
|
||||
(when (and eng-gate (fboundp eng-gate))
|
||||
(setf current-action (funcall (symbol-function eng-gate) current-action context)))))))
|
||||
"The main policy gate. Runs invariant checks, then delegates to engineering standards if available.
|
||||
Never returns NIL silently; always returns an action or an auditable log event."
|
||||
(let ((current-action (policy-run-invariant-checks action context)))
|
||||
;; If an invariant returned a blocking log, do not proceed further
|
||||
(when (and (listp current-action)
|
||||
(member (getf current-action :type) '(:LOG :EVENT))
|
||||
(eq (getf (getf current-action :payload) :level) :error))
|
||||
(return-from policy-deterministic-gate current-action))
|
||||
;; Delegate to Engineering Standards if loaded
|
||||
(let ((eng-gate (policy-find-engineering-standards-gate)))
|
||||
(when eng-gate
|
||||
(setf current-action (funcall eng-gate current-action context))))
|
||||
current-action))
|
||||
|
||||
(defskill :skill-policy
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) t)
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:probabilistic nil
|
||||
:deterministic #'policy-deterministic-gate)
|
||||
|
||||
@@ -50,12 +50,14 @@
|
||||
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
||||
(system-prompt (format nil "IDENTITY: ~a. MANDATE: Respond with ONE Lisp plist. ~a ~a RECENT_LOGS: ~a
|
||||
IMPORTANT: To reply to the user, you MUST use:
|
||||
(:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"<Response Text>\"))
|
||||
(:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT "<Response Text>"))
|
||||
|
||||
To call a tool, you MUST use:
|
||||
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL \"<name>\" :ARGS (:arg1 \"val\"))
|
||||
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL "<name>" :ARGS (:arg1 "val"))
|
||||
|
||||
PROVIDER RULE: Always use the default cascade provider unless a specific model or capability is required for the task."
|
||||
MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete, you MUST call the `:validate-lisp` tool with the proposed code. If the tool returns `:status :error`, read the `:reason` and `:failed` fields, fix the defect, and re-validate. You are strictly forbidden from relying on your own paren-balancing or syntax intuition.
|
||||
|
||||
PROVIDER RULE: Always use the default cascade provider unless a specific model or capability is required for the task."
|
||||
assistant-name global-context tool-belt system-logs)))
|
||||
(let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (strip-markdown thought))
|
||||
|
||||
@@ -109,13 +109,14 @@
|
||||
(nreverse result))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid, readable Common Lisp forms."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof))
|
||||
(values t nil)))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
"Checks if a string contains valid, readable Common Lisp forms.
|
||||
Delegates to the Lisp Validator skill for structural + syntactic validation."
|
||||
(let* ((result (lisp-validator-validate code-string :strict nil))
|
||||
(status (getf result :status))
|
||||
(reason (getf result :reason)))
|
||||
(if (eq status :success)
|
||||
(values t nil)
|
||||
(values nil (or reason "Lisp Validator rejected code.")))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file into a jailed package."
|
||||
|
||||
382
skills/org-skill-lisp-validator.org
Normal file
382
skills/org-skill-lisp-validator.org
Normal file
@@ -0,0 +1,382 @@
|
||||
:PROPERTIES:
|
||||
:ID: lisp-validator-skill
|
||||
:CREATED: [2026-04-22 Wed 12:15]
|
||||
:EDITED: [2026-04-22 Wed 12:15]
|
||||
:END:
|
||||
#+TITLE: SKILL: Lisp Validator (Structural & Semantic Gate)
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :security:lisp:ast:autonomy:modularity:
|
||||
|
||||
* Overview
|
||||
The *Lisp Validator* is the primary structural gate for the Probabilistic-Deterministic Lisp Machine. It eliminates the token-waste of probabilistic paren-balancing by providing a deterministic, three-phase validation pipeline: Structural, Syntactic, and Semantic. It is exposed as a cognitive tool so both the harness and the Probabilistic Engine can invoke it before declaring code complete.
|
||||
|
||||
* Phase A: Demand (PRD)
|
||||
:PROPERTIES:
|
||||
:STATUS: SIGNED
|
||||
:END:
|
||||
|
||||
** 1. Purpose
|
||||
Provide a deterministic, fast, and auditable validation gate for all Lisp code proposals.
|
||||
|
||||
** 2. User Needs
|
||||
- *Structural Validation:* Detect unbalanced parentheses, brackets, and unterminated strings without invoking the reader.
|
||||
- *Syntactic Validation:* Ensure the code can be read by SBCL with `*read-eval*` disabled.
|
||||
- *Semantic Validation:* Optionally enforce a whitelist of safe symbols for sandboxed execution.
|
||||
- *Tool Exposure:* The Probabilistic Engine must be able to call this as a cognitive tool.
|
||||
|
||||
** 3. Success Criteria
|
||||
- [X] Structural check runs in O(n) and catches all paren/string defects.
|
||||
- [X] Syntactic check catches reader errors and malformed sexps.
|
||||
- [X] Semantic check blocks non-whitelisted symbols when strict mode is enabled.
|
||||
- [X] Returns structured plist for machine parsing and human explanation.
|
||||
|
||||
* Phase B: Blueprint (PROTOCOL)
|
||||
:PROPERTIES:
|
||||
:STATUS: SIGNED
|
||||
:END:
|
||||
|
||||
** 1. Architectural Intent
|
||||
A single entry point, `lisp-validator-validate`, runs three sequential checks. Each check is isolated so a failure in one does not obscure failures in others. The function returns a unified result plist.
|
||||
|
||||
** 2. Semantic Interfaces
|
||||
- `(lisp-validator-validate code-string &key strict)` → plist
|
||||
- Tool `:validate-lisp` with args `(:code "..." :strict t/nil)`
|
||||
|
||||
* Phase D: Build (Implementation)
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-lisp-validator.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Check 1: Structural Validation (Paren Balance)
|
||||
Scans the raw string character-by-character, tracking open/close pairs for `()`, `[]`, `#()`, and string delimiters `"`. Ignores escaped characters and line comments (`;`). This is O(n) and does not invoke the Lisp reader.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-lisp-validator.lisp
|
||||
(defun lisp-validator-check-structural (code-string)
|
||||
"Checks for balanced parens, brackets, and terminated strings.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil reason-string line col)."
|
||||
(let ((stack nil)
|
||||
(in-string nil)
|
||||
(escaped nil)
|
||||
(line 1)
|
||||
(col 0)
|
||||
(last-open-line 1)
|
||||
(last-open-col 0))
|
||||
(dotimes (i (length code-string)
|
||||
(if (null stack)
|
||||
(values t nil nil nil)
|
||||
(values nil (format nil "Unbalanced '~a' opened at line ~a, col ~a"
|
||||
(caar stack) last-open-line last-open-col)
|
||||
last-open-line last-open-col)))
|
||||
(let ((ch (char code-string i)))
|
||||
(cond (escaped (setf escaped nil))
|
||||
((char= ch #\\) (setf escaped t))
|
||||
(in-string
|
||||
(when (char= ch #\") (setf in-string nil)))
|
||||
((char= ch #\;)
|
||||
;; Skip to end of line
|
||||
(loop while (and (< i (1- (length code-string)))
|
||||
(not (char= (char code-string (1+ i)) #\Newline)))
|
||||
do (incf i))
|
||||
(incf line) (setf col 0))
|
||||
((char= ch #\")
|
||||
(setf in-string t))
|
||||
((member ch '(#\( #\[))
|
||||
(push (list (string ch) line col) stack)
|
||||
(setf last-open-line line last-open-col col))
|
||||
((char= ch #\))
|
||||
(cond ((null stack)
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Unexpected ')' at line ~a, col ~a" line col) line col)))
|
||||
((string= (caar stack) "[")
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Mismatched ']' expected at line ~a, col ~a" line col) line col)))
|
||||
(t (pop stack))))
|
||||
((char= ch #\])
|
||||
(cond ((null stack)
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Unexpected ']' at line ~a, col ~a" line col) line col)))
|
||||
((string= (caar stack) "(")
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Mismatched ')' expected at line ~a, col ~a" line col) line col)))
|
||||
(t (pop stack))))
|
||||
((char= ch #\Newline)
|
||||
(incf line) (setf col 0)))
|
||||
(unless (char= ch #\Newline) (incf col))))))
|
||||
#+end_src
|
||||
|
||||
** Check 2: Syntactic Validation (Reader Check)
|
||||
Wraps the code in `(progn ...)` and attempts to read every top-level form with `*read-eval*` disabled. Catches reader errors, invalid syntax, and malformed sexps that the structural check cannot detect (e.g., invalid reader macros).
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-lisp-validator.lisp
|
||||
(defun lisp-validator-check-syntactic (code-string)
|
||||
"Checks if the code can be read by SBCL with *read-eval* nil.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil error-message line col)."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof)))
|
||||
(values t nil nil nil))
|
||||
(error (c)
|
||||
(let ((msg (format nil "~a" c)))
|
||||
(values nil msg nil nil)))))
|
||||
#+end_src
|
||||
|
||||
** Check 3: Semantic Validation (Whitelist AST Walk)
|
||||
Recursively walks the parsed AST and verifies that every function call and symbol reference appears on a whitelist. This is the "Deny-by-Default" sandbox. When `strict` is nil, this check is skipped for general validation (e.g., skill loading) but enforced for `:eval` tool execution.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-lisp-validator.lisp
|
||||
(defparameter *lisp-validator-whitelist*
|
||||
'(;; Math & Logic
|
||||
+ - * / = < > <= >= 1+ 1- min max mod abs floor ceiling round
|
||||
and or not null eq eql equal string= string-equal char= char-equal
|
||||
;; List Manipulation
|
||||
list cons car cdr cadr cddr cdar caar caddr cdddr append mapcar remove-if remove-if-not
|
||||
length reverse sort nth nthcdr push pop last butlast subseq
|
||||
;; Plists, Alists, and Hash Tables
|
||||
getf gethash assoc acons pairlis rassoc
|
||||
;; Control Flow
|
||||
let let* if cond when unless case typecase prog1 progn
|
||||
;; Strings
|
||||
format concatenate string-downcase string-upcase search subseq replace
|
||||
;; Type predicates
|
||||
stringp numberp integerp listp symbolp keywordp null
|
||||
;; Kernel safe symbols
|
||||
opencortex::harness-log
|
||||
opencortex::snapshot-memory opencortex::rollback-memory
|
||||
opencortex::lookup-object opencortex::list-objects-by-type
|
||||
opencortex::ingest-ast opencortex::find-headline-missing-id
|
||||
opencortex::context-query-store opencortex::context-get-active-projects
|
||||
opencortex::context-get-recent-completed-tasks opencortex::context-list-all-skills
|
||||
opencortex::context-get-system-logs opencortex::context-assemble-global-awareness
|
||||
opencortex::org-object-id opencortex::org-object-type opencortex::org-object-attributes
|
||||
opencortex::org-object-content opencortex::org-object-parent-id
|
||||
opencortex::org-object-children opencortex::org-object-version
|
||||
opencortex::org-object-last-sync opencortex::org-object-hash
|
||||
opencortex::org-object-vector
|
||||
;; Essential macros and special operators
|
||||
declare ignore quote function lambda defun defvar defparameter defmacro
|
||||
;; Safe I/O
|
||||
with-open-file write-string read-line
|
||||
;; Package introspection
|
||||
find-package make-package in-package do-external-symbols find-symbol
|
||||
;; Safe system interaction
|
||||
uiop:run-program uiop:getenv uiop:merge-pathnames* uiop:file-exists-p
|
||||
uiop:directory-exists-p uiop:read-file-string uiop:split-string
|
||||
;; Time
|
||||
get-universal-time get-internal-real-time sleep
|
||||
;; Equality
|
||||
equalp = equal eq eql))
|
||||
"Static whitelist of symbols permitted in the Lisp Validator sandbox."
|
||||
|
||||
(defvar *lisp-validator-registry* nil
|
||||
"List of dynamically registered safe symbols.")
|
||||
|
||||
(defun lisp-validator-register (symbols)
|
||||
"Adds symbols to the global validator registry."
|
||||
(setf *lisp-validator-registry*
|
||||
(append *lisp-validator-registry*
|
||||
(if (listp symbols) symbols (list symbols))))
|
||||
(harness-log "LISP VALIDATOR: Registered ~a new safe symbols."
|
||||
(length (if (listp symbols) symbols (list symbols)))))
|
||||
|
||||
(defun lisp-validator-is-safe (symbol)
|
||||
"Checks if a symbol is in the static whitelist or the dynamic registry."
|
||||
(or (member symbol *lisp-validator-whitelist* :test #'string-equal)
|
||||
(member symbol *lisp-validator-registry* :test #'string-equal)))
|
||||
|
||||
(defun lisp-validator-ast-walk (form)
|
||||
"Recursively walks the Lisp AST. Returns T if safe, NIL if unsafe."
|
||||
(cond
|
||||
;; Self-evaluating objects are safe.
|
||||
((or (stringp form) (numberp form) (keywordp form) (characterp form)) t)
|
||||
;; Symbols used as variables (in non-function position)
|
||||
((symbolp form) (lisp-validator-is-safe form))
|
||||
;; Lists represent function calls or special forms.
|
||||
((listp form)
|
||||
(let ((head (car form)))
|
||||
(cond
|
||||
((eq head 'quote) t)
|
||||
((not (symbolp head)) nil)
|
||||
((lisp-validator-is-safe head)
|
||||
(every #'lisp-validator-ast-walk (cdr form)))
|
||||
(t
|
||||
(harness-log "LISP VALIDATOR: Blocked call to non-whitelisted function ~a" head)
|
||||
nil))))
|
||||
(t nil)))
|
||||
|
||||
(defun lisp-validator-check-semantic (code-string)
|
||||
"Checks if all symbols in CODE-STRING are whitelisted.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil reason-string nil nil)."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof)
|
||||
until (eq form :eof)
|
||||
do (unless (lisp-validator-ast-walk form)
|
||||
(return-from lisp-validator-check-semantic
|
||||
(values nil "Code contains non-whitelisted symbols." nil nil)))))
|
||||
(values t nil nil nil))
|
||||
(error (c)
|
||||
(values nil (format nil "Semantic check failed: ~a" c) nil nil))))
|
||||
#+end_src
|
||||
|
||||
** Unified Entry Point
|
||||
Orchestrates the three checks and returns a single structured plist.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-lisp-validator.lisp
|
||||
(defun lisp-validator-validate (code-string &key strict)
|
||||
"Validates Lisp code through structural, syntactic, and optional semantic checks.
|
||||
Returns a plist:
|
||||
(:status :success :checks (:structural t :syntactic t :semantic t))
|
||||
or
|
||||
(:status :error :failed <check-key> :reason <string> :line <n> :col <n>)
|
||||
|
||||
When STRICT is non-nil, the semantic whitelist check is enforced.
|
||||
When STRICT is nil, semantic check is skipped for general validation."
|
||||
(let ((structural-ok nil) (syntactic-ok nil) (semantic-ok nil)
|
||||
(reason nil) (line nil) (col nil))
|
||||
;; Phase 1: Structural
|
||||
(multiple-value-setq (structural-ok reason line col)
|
||||
(lisp-validator-check-structural code-string))
|
||||
(unless structural-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :structural :reason reason :line line :col col)))
|
||||
;; Phase 2: Syntactic
|
||||
(multiple-value-setq (syntactic-ok reason line col)
|
||||
(lisp-validator-check-syntactic code-string))
|
||||
(unless syntactic-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :syntactic :reason reason :line line :col col)))
|
||||
;; Phase 3: Semantic (only when strict)
|
||||
(when strict
|
||||
(multiple-value-setq (semantic-ok reason line col)
|
||||
(lisp-validator-check-semantic code-string))
|
||||
(unless semantic-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :semantic :reason reason :line line :col col))))
|
||||
;; All clear
|
||||
(list :status :success
|
||||
:checks (list :structural t :syntactic t :semantic (or (not strict) semantic-ok)))))
|
||||
#+end_src
|
||||
|
||||
** Cognitive Tool: :validate-lisp
|
||||
Exposes the validator to the Probabilistic Engine so it can self-correct before presenting code.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-lisp-validator.lisp
|
||||
(def-cognitive-tool :validate-lisp
|
||||
"Deterministically validates Lisp code for structural, syntactic, and semantic correctness.
|
||||
Use this BEFORE declaring any Lisp code edit complete."
|
||||
((:code :type :string :description "The Lisp code string to validate.")
|
||||
(:strict :type :boolean :description "If non-nil, enforces the semantic whitelist."))
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code))
|
||||
(strict (getf args :strict)))
|
||||
(if (and code (stringp code))
|
||||
(lisp-validator-validate code :strict strict)
|
||||
(list :status :error :reason "Missing :code argument.")))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-lisp-validator.lisp
|
||||
(defskill :skill-lisp-validator
|
||||
:priority 900
|
||||
:trigger (lambda (ctx)
|
||||
;; Trigger on any eval or shell action, or when validation is explicitly requested
|
||||
(let ((candidate (getf ctx :approved-action)))
|
||||
(when candidate
|
||||
(let ((payload (getf candidate :payload)))
|
||||
(member (getf payload :action) '(:eval :shell))))))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(let ((payload (getf action :payload)))
|
||||
(if (eq (getf payload :action) :eval)
|
||||
(let* ((code (getf payload :code))
|
||||
(result (lisp-validator-validate code :strict t)))
|
||||
(if (eq (getf result :status) :error)
|
||||
(progn
|
||||
(harness-log "LISP VALIDATOR: Blocked unsafe :eval action. ~a"
|
||||
(getf result :reason))
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "LISP VALIDATOR: Blocked unsafe eval. ~a"
|
||||
(getf result :reason)))))
|
||||
action))
|
||||
action))))
|
||||
#+end_src
|
||||
|
||||
* Phase E: Chaos (Verification)
|
||||
#+begin_src lisp :tangle ../tests/lisp-validator-tests.lisp
|
||||
(defpackage :opencortex-lisp-validator-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:lisp-validator-suite))
|
||||
|
||||
(in-package :opencortex-lisp-validator-tests)
|
||||
|
||||
(def-suite lisp-validator-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates.")
|
||||
|
||||
(in-suite lisp-validator-suite)
|
||||
|
||||
(test structural-balanced
|
||||
(let ((result (opencortex::lisp-validator-check-structural "(+ 1 2)")))
|
||||
(is (eq result t))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-structural "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Unbalanced" reason))
|
||||
(is (= line 1))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-structural "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Unexpected" reason)))
|
||||
|
||||
(test structural-mismatched-bracket
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-structural "(let [x 1) x)")
|
||||
(is (null ok))
|
||||
(is (search "Mismatched" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-syntactic "(+ 1 2) (* 3 4)")
|
||||
(is ok)))
|
||||
|
||||
(test syntactic-invalid-reader
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-syntactic "(1+ 2 #")")
|
||||
(is (null ok))))
|
||||
|
||||
(test semantic-safe
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-semantic "(+ 1 2)")
|
||||
(is ok)))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-semantic "(eval '(+ 1 2))")
|
||||
(is (null ok))))
|
||||
|
||||
(test unified-success
|
||||
(let ((result (opencortex::lisp-validator-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (getf (getf result :checks) :structural))
|
||||
(is (getf (getf result :checks) :syntactic))
|
||||
(is (getf (getf result :checks) :semantic))))
|
||||
|
||||
(test unified-structural-failure
|
||||
(let ((result (opencortex::lisp-validator-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (eq (getf result :failed) :structural))))
|
||||
|
||||
(test unified-semantic-failure-strict
|
||||
(let ((result (opencortex::lisp-validator-validate "(delete-file \"x.txt\")" :strict t)))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (eq (getf result :failed) :semantic))))
|
||||
#+end_src
|
||||
@@ -1,7 +1,7 @@
|
||||
:PROPERTIES:
|
||||
:ID: 47425a43-2be0-423c-8509-22592cfe9c9e
|
||||
:CREATED: [2026-04-07 Tue 12:57]
|
||||
:EDITED: [2026-04-13 Mon 18:30]
|
||||
:EDITED: [2026-04-22 Wed 11:45]
|
||||
:END:
|
||||
#+TITLE: SKILL: System Policy
|
||||
#+STARTUP: content
|
||||
@@ -10,6 +10,8 @@
|
||||
* Overview
|
||||
The *opencortex* is a probabilistic-deterministic harness for a personal operating system. It uses Org-mode as its native memory and Common Lisp as its deterministic reasoning engine.
|
||||
|
||||
This skill defines the *Core System Policy*: a set of non-negotiable philosophical and technical constraints that every agentic action MUST satisfy. Unlike a passive manifesto, these invariants are enforced by the Deterministic Engine at the last mile before actuation.
|
||||
|
||||
* Package Context
|
||||
Every skill executes within its own jailed package namespace, while inheriting core harness symbols.
|
||||
|
||||
@@ -17,57 +19,292 @@ Every skill executes within its own jailed package namespace, while inheriting c
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
* The Core Invariants
|
||||
This document contains the *Core System Policy*. These are non-negotiable philosophical and technical constraints that every agentic action MUST satisfy. The Deterministic Engine uses these headlines as a "Moral Compass" during the decision stage.
|
||||
* The Override Hierarchy
|
||||
When two invariants conflict, resolution follows a strict priority order. This prevents the agent from freezing on ethical edge cases.
|
||||
|
||||
** 1. Autonomy Above All
|
||||
Every action must increase the user's independence from centralized, proprietary platforms. If a tool or library introduces a dependency on a non-autonomous entity, it must be flagged for replacement.
|
||||
1. *Radical Transparency* — An action that cannot be explained to the user is never permissible, even if it is technically optimal.
|
||||
2. *Autonomy* — Independence from proprietary control is the primary goal, but it must be achieved transparently.
|
||||
3. *Zero-Bloat* — Complexity must be justified, but a transparent, autonomous system may still be complex if the complexity is locally justified.
|
||||
4. *Modularity* — The system's kernel must remain minimal; complexity must live at the edges, not in the core. This takes precedence over mentorship when the proposed change would fatten the harness.
|
||||
5. *Mentorship* — The agent must teach, but teaching is secondary to delivering a working, transparent system.
|
||||
6. *Long-Term Sustainability* — Energy efficiency and offline capability are desired properties, not absolute blockers.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defun policy-check-autonomy (action context)
|
||||
"Ensures the action does not violate the Autonomy invariant."
|
||||
(declare (ignore context))
|
||||
;; Implementation placeholder: currently permits all actions.
|
||||
;; Future: Scan for non-autonomous domain names or proprietary API endpoints.
|
||||
action)
|
||||
(defvar *policy-invariant-priorities*
|
||||
'((:transparency . 500)
|
||||
(:autonomy . 400)
|
||||
(:bloat . 300)
|
||||
(:modularity . 250)
|
||||
(:mentorship . 200)
|
||||
(:sustainability . 100))
|
||||
"Priority alist for policy invariant conflict resolution.
|
||||
Higher numbers take precedence.")
|
||||
#+end_src
|
||||
|
||||
** 2. Technical Mastery & Mentorship
|
||||
The agent's goal is not to "do it for the user," but to "empower the user." Every autonomous action must be explained at a level that increases the user's technical understanding of the Lisp Machine.
|
||||
* The Core Invariants
|
||||
|
||||
** 3. Zero-Bloat Mandate
|
||||
The system harness must remain minimalist. "Just-in-case" code is a security vulnerability. Complexity must be earned, not imported.
|
||||
|
||||
** 4. Radical Transparency
|
||||
The agent's "Thought Stream" must be fully auditable. Hidden reasoning or obfuscated logic is a violation of the system's design principles.
|
||||
|
||||
** 5. Long-Term Sustainability
|
||||
Prioritize local, energy-efficient, and offline-first architectures. The "Memex" should be functional in a 100-year horizon.
|
||||
|
||||
* The Policy Gate
|
||||
The main deterministic entry point for the policy skill. It orchestrates the various invariant checks and delegates to engineering standards.
|
||||
** 1. Radical Transparency
|
||||
The agent's "Thought Stream" must be fully auditable. Hidden reasoning or obfuscated logic is a violation of the system's design principles. At the action gate, this means every action directed at the user MUST carry an explanation, and every action MUST be a valid, inspectable data structure.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defun policy-check-transparency (action context)
|
||||
"Ensures the action is inspectable and user-facing actions carry an explanation.
|
||||
Returns the action if clean, or a blocking LOG event if the action is opaque."
|
||||
(declare (ignore context))
|
||||
(unless (listp action)
|
||||
(return-from policy-check-transparency
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Transparency]: Action is not a valid plist. Rejected."))))
|
||||
(let* ((payload (getf action :payload))
|
||||
(target (or (getf action :target) (getf action :TARGET)))
|
||||
(explanation (or (getf payload :explanation) (getf payload :EXPLANATION)
|
||||
(getf payload :rationale) (getf payload :RATIONALE))))
|
||||
;; User-facing actions (CLI, TUI, Emacs) must explain themselves
|
||||
(when (and (member target '(:cli :tui :emacs :EMACS :CLI :TUI))
|
||||
(not explanation)
|
||||
(not (member (getf payload :action)
|
||||
'(:handshake :heartbeat :status-update))))
|
||||
(return-from policy-check-transparency
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Transparency]: User-facing action missing :explanation. Blocked."))))
|
||||
action))
|
||||
#+end_src
|
||||
|
||||
** 2. Autonomy Above All
|
||||
Every action must increase the user's independence from centralized, proprietary platforms. If a tool or library introduces a dependency on a non-autonomous entity, it must be flagged for replacement. The gate scans shell commands and tool payloads for known proprietary domains and logs a warning. It does NOT block by default, because the system itself uses gateway bridges (e.g., Telegram, Signal) as tactical concessions toward strategic autonomy.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defvar *proprietary-domain-watchlist*
|
||||
'("googleapis.com" "api.openai.com" "anthropic.com" "api.groq.com" "openrouter.ai")
|
||||
"Domains that represent centralized, proprietary control.
|
||||
Actions targeting these are logged as autonomy debt, not hard-blocked,
|
||||
because tactical gateway usage is permitted under the strategic mandate.")
|
||||
|
||||
(defun policy-scan-proprietary-references (action)
|
||||
"Scans ACTION text fields for proprietary domain references.
|
||||
Returns the first matched domain, or NIL if clean."
|
||||
(let* ((payload (getf action :payload))
|
||||
(text (or (getf payload :text) (getf payload :TEXT) ""))
|
||||
(cmd (or (getf payload :cmd) (getf payload :CMD)
|
||||
(when (equal (getf payload :tool) "shell")
|
||||
(getf (getf payload :args) :cmd))
|
||||
""))
|
||||
(haystack (concatenate 'string text cmd)))
|
||||
(dolist (domain *proprietary-domain-watchlist* nil)
|
||||
(when (search domain haystack)
|
||||
(return domain)))))
|
||||
|
||||
(defun policy-check-autonomy (action context)
|
||||
"Flags actions that reference proprietary domains. Returns the action
|
||||
with an autonomy debt log appended, or the action itself if clean."
|
||||
(declare (ignore context))
|
||||
(let ((domain (policy-scan-proprietary-references action)))
|
||||
(if domain
|
||||
(progn
|
||||
(harness-log "POLICY [Autonomy]: Detected proprietary reference '~a'. Flagged for replacement." domain)
|
||||
;; Return a side-effect log but DO NOT block the action
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Autonomy Debt: Action references proprietary domain '~a'. Consider a local alternative." domain)
|
||||
:original-action action)))
|
||||
action)))
|
||||
#+end_src
|
||||
|
||||
** 3. Zero-Bloat Mandate
|
||||
The system harness must remain minimalist. "Just-in-case" code is a security vulnerability. Complexity must be earned, not imported. This invariant is enforced primarily at skill-load time (see `validate-lisp-syntax` and skill telemetry). At the action gate, it performs a lightweight size check on proposed `:create-skill` actions and warns if the payload exceeds a reasonable threshold.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defvar *policy-max-skill-size-chars* 50000
|
||||
"Maximum recommended size for a skill file tangled from an Org note.")
|
||||
|
||||
(defun policy-check-bloat (action context)
|
||||
"Warns if a :create-skill action exceeds the bloat threshold.
|
||||
Does not block, because size alone is not a proof of complexity."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(act (getf payload :action))
|
||||
(content (getf payload :content)))
|
||||
(when (and (eq act :create-skill)
|
||||
(stringp content)
|
||||
(> (length content) *policy-max-skill-size-chars*))
|
||||
(harness-log "POLICY [Bloat]: Proposed skill is ~a chars. Exceeds ~a char threshold."
|
||||
(length content) *policy-max-skill-size-chars*)
|
||||
(return-from policy-check-bloat
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Bloat Warning: Proposed skill (~a chars) exceeds ~a char threshold. Review for earned complexity."
|
||||
(length content) *policy-max-skill-size-chars*)
|
||||
:original-action action))))
|
||||
action))
|
||||
#+end_src
|
||||
|
||||
** 4. Technical Mastery & Mentorship
|
||||
The agent's goal is not to "do it for the user," but to "empower the user." Every autonomous action must be explained at a level that increases the user's technical understanding of the Lisp Machine. At the gate, this means that any action which performs a non-trivial side-effect (file write, shell execution, skill reload) MUST include a `:mentorship-note` explaining *what* was done and *why*.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defvar *mentorship-required-actions*
|
||||
'(:create-skill :eval :modify-file :write-file :replace :rename-file :delete-file :shell :create-note)
|
||||
"Actions that trigger the Mentorship invariant.")
|
||||
|
||||
(defun policy-check-mentorship (action context)
|
||||
"Blocks high-impact actions that lack a mentorship note."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(act (or (getf payload :action) (getf action :action)))
|
||||
(note (or (getf payload :mentorship-note) (getf payload :MENTORSHIP-NOTE)))
|
||||
(target (or (getf action :target) (getf action :TARGET)))
|
||||
(tool (when (eq target :tool) (getf payload :tool))))
|
||||
(when (or (member act *mentorship-required-actions*)
|
||||
(member tool '("shell" "eval" "repair-file")))
|
||||
(unless note
|
||||
(return-from policy-check-mentorship
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Mentorship]: High-impact action missing :mentorship-note. Explain what you are doing and why. Blocked.")))))
|
||||
action))
|
||||
#+end_src
|
||||
|
||||
** 5. Long-Term Sustainability
|
||||
Prioritize local, energy-efficient, and offline-first architectures. The "Memex" should be functional on a 100-year horizon. At the gate, this means we log a sustainability debt event whenever the probabilistic engine falls back to a remote cloud provider because a local model (e.g., Ollama) is unavailable.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defvar *cloud-only-backends* '(:openrouter :openai :anthropic :groq :gemini-api)
|
||||
"Backends that require an internet connection and external infrastructure.")
|
||||
|
||||
(defun policy-check-sustainability (action context)
|
||||
"Logs sustainability debt when the action relies on cloud-only infrastructure.
|
||||
Does not block, because tactical cloud usage is permitted."
|
||||
(let* ((payload (getf context :payload))
|
||||
(backend (getf payload :backend))
|
||||
(provider (getf payload :provider)))
|
||||
(when (or (member backend *cloud-only-backends*)
|
||||
(member provider *cloud-only-backends*))
|
||||
(harness-log "POLICY [Sustainability]: Cloud provider '~a' used. Logged as sustainability debt."
|
||||
(or backend provider))
|
||||
(return-from policy-check-sustainability
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Sustainability Debt: Reliance on cloud provider '~a'. Consider Ollama or local inference."
|
||||
(or backend provider))))))
|
||||
action))
|
||||
#+end_src
|
||||
|
||||
** 6. Modularity
|
||||
Every system should be decomposed into a minimal, unbreakable core and hot-swappable capabilities. Complexity must live at the edges, never in the kernel. At the gate, this means any proposed modification to the protected core must carry a `:modularity-justification` explaining why the change cannot be implemented as a skill.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defvar *modularity-protected-paths*
|
||||
'("harness/" "opencortex.asd")
|
||||
"Paths that constitute the unbreakable core of the system.
|
||||
Any action targeting these paths must include a :modularity-justification.
|
||||
This list is project-specific and should be configured at boot time.")
|
||||
|
||||
(defun policy-check-modularity (action context)
|
||||
"Blocks modifications to the system's protected core unless justified."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(target-file (or (getf payload :file) (getf payload :filename)))
|
||||
(justification (or (getf payload :modularity-justification)
|
||||
(getf payload :MODULARITY-JUSTIFICATION))))
|
||||
(when (and target-file
|
||||
(some (lambda (path) (search path target-file)) *modularity-protected-paths*)
|
||||
(not justification))
|
||||
(return-from policy-check-modularity
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Modularity]: Modification to protected core path blocked. Provide :modularity-justification explaining why this cannot be a skill."
|
||||
:blocked-path target-file))))
|
||||
action))
|
||||
#+end_src
|
||||
|
||||
* The Policy Explanation Engine
|
||||
When the policy gate modifies or blocks an action, it must tell the user *why*. This function formats a human-readable rationale from the invariant that triggered the interception.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defun policy-explain (invariant-key message &optional original-action)
|
||||
"Formats a policy decision into an auditable explanation plist.
|
||||
INVARIANT-KEY is one of :transparency, :autonomy, :bloat, :modularity, :mentorship, :sustainability.
|
||||
MESSAGE is a human-readable string.
|
||||
ORIGINAL-ACTION is the action that was blocked or modified."
|
||||
(list :type :REQUEST
|
||||
:target (or (ignore-errors (getf (getf original-action :meta) :source)) :cli)
|
||||
:payload (list :action :message
|
||||
:text (format nil "[POLICY ~a] ~a" invariant-key message)
|
||||
:explanation (format nil "Invariant: ~a | Rationale: ~a" invariant-key message)
|
||||
:original-action original-action)))
|
||||
#+end_src
|
||||
|
||||
* The Policy Gate
|
||||
The main deterministic entry point for the policy skill. It runs invariant checks in priority order. If a check returns a blocking LOG event, the gate immediately yields with an explanation. If a check returns a modified action (e.g., a warning wrapper), the modified action is passed down the chain.
|
||||
|
||||
The gate also attempts to delegate to Engineering Standards, but it does so robustly: it searches multiple candidate package names and falls back gracefully if the standards skill is not loaded.
|
||||
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defun policy-run-invariant-checks (action context)
|
||||
"Runs all invariant checks in priority order. Returns the final action,
|
||||
a blocking LOG event, or a warning wrapper."
|
||||
(let ((checks '(policy-check-transparency
|
||||
policy-check-autonomy
|
||||
policy-check-bloat
|
||||
policy-check-modularity
|
||||
policy-check-mentorship
|
||||
policy-check-sustainability)))
|
||||
(dolist (check-fn checks action)
|
||||
(let ((result (funcall check-fn action context)))
|
||||
;; If the check returned a LOG event, treat it as a block/warning
|
||||
(when (and (listp result)
|
||||
(member (getf result :type) '(:LOG :EVENT)))
|
||||
(let ((level (getf (getf result :payload) :level)))
|
||||
(cond ((eq level :error)
|
||||
;; Hard block: return the log event directly
|
||||
(return-from policy-run-invariant-checks result))
|
||||
(t
|
||||
;; Warning: log it, but continue with the original action
|
||||
(harness-log "~a" (getf (getf result :payload) :text))))))))))
|
||||
|
||||
(defun policy-find-engineering-standards-gate ()
|
||||
"Searches for the Engineering Standards gate across known jailed package names.
|
||||
Returns the function symbol, or NIL if unavailable."
|
||||
(dolist (pkg-name '(:opencortex.skills.org-skill-engineering-standards
|
||||
:opencortex.skills.org-skill-engineering
|
||||
:opencortex.skills.engineering-standards)
|
||||
nil)
|
||||
(let ((pkg (find-package pkg-name)))
|
||||
(when pkg
|
||||
(let ((sym (find-symbol "ENGINEERING-STANDARDS-GATE" pkg)))
|
||||
(when (and sym (fboundp sym))
|
||||
(return (symbol-function sym))))))))
|
||||
|
||||
(defun policy-deterministic-gate (action context)
|
||||
"The main policy gate. Sub-calls engineering standards if available."
|
||||
(let ((current-action (policy-check-autonomy action context)))
|
||||
(when current-action
|
||||
(let ((eng-pkg (find-package :opencortex.skills.org-skill-engineering-standards)))
|
||||
(when eng-pkg
|
||||
(let ((eng-gate (find-symbol "ENGINEERING-STANDARDS-GATE" eng-pkg)))
|
||||
(when (and eng-gate (fboundp eng-gate))
|
||||
(setf current-action (funcall (symbol-function eng-gate) current-action context)))))))
|
||||
"The main policy gate. Runs invariant checks, then delegates to engineering standards if available.
|
||||
Never returns NIL silently; always returns an action or an auditable log event."
|
||||
(let ((current-action (policy-run-invariant-checks action context)))
|
||||
;; If an invariant returned a blocking log, do not proceed further
|
||||
(when (and (listp current-action)
|
||||
(member (getf current-action :type) '(:LOG :EVENT))
|
||||
(eq (getf (getf current-action :payload) :level) :error))
|
||||
(return-from policy-deterministic-gate current-action))
|
||||
;; Delegate to Engineering Standards if loaded
|
||||
(let ((eng-gate (policy-find-engineering-standards-gate)))
|
||||
(when eng-gate
|
||||
(setf current-action (funcall eng-gate current-action context))))
|
||||
current-action))
|
||||
#+end_src
|
||||
|
||||
* Operational Mandates
|
||||
Every action performed by an agent in this environment must also adhere to the [[file:org-skill-engineering-standards.org][Engineering Standards]].
|
||||
Every action performed by an agent in this environment must also adhere to the Engineering Standards. The policy skill evaluates every context (trigger is always true) because invariants are universal.
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp :tangle ../library/gen/org-skill-policy.lisp
|
||||
(defskill :skill-policy
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) t)
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:probabilistic nil
|
||||
:deterministic #'policy-deterministic-gate)
|
||||
#+end_src
|
||||
|
||||
* See Also
|
||||
- [[file:org-skill-engineering-standards.org][Engineering Standards]] (if loaded)
|
||||
- [[file:../harness/act.org][Act Stage]] (where the Bouncer and Policy gates are invoked)
|
||||
|
||||
70
tests/lisp-validator-tests.lisp
Normal file
70
tests/lisp-validator-tests.lisp
Normal file
@@ -0,0 +1,70 @@
|
||||
(defpackage :opencortex-lisp-validator-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:lisp-validator-suite))
|
||||
|
||||
(in-package :opencortex-lisp-validator-tests)
|
||||
|
||||
(def-suite lisp-validator-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates.")
|
||||
|
||||
(in-suite lisp-validator-suite)
|
||||
|
||||
(test structural-balanced
|
||||
(let ((result (opencortex::lisp-validator-check-structural "(+ 1 2)")))
|
||||
(is (eq result t))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-structural "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Unbalanced" reason))
|
||||
(is (= line 1))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-structural "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Unexpected" reason)))
|
||||
|
||||
(test structural-mismatched-bracket
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-structural "(let [x 1) x)")
|
||||
(is (null ok))
|
||||
(is (search "Mismatched" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-syntactic "(+ 1 2) (* 3 4)")
|
||||
(is ok)))
|
||||
|
||||
(test syntactic-invalid-reader
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-syntactic "(1+ 2 #")")
|
||||
(is (null ok))))
|
||||
|
||||
(test semantic-safe
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-semantic "(+ 1 2)")
|
||||
(is ok)))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
(multiple-value-bind (ok reason line col)
|
||||
(opencortex::lisp-validator-check-semantic "(eval '(+ 1 2))")
|
||||
(is (null ok))))
|
||||
|
||||
(test unified-success
|
||||
(let ((result (opencortex::lisp-validator-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (getf (getf result :checks) :structural))
|
||||
(is (getf (getf result :checks) :syntactic))
|
||||
(is (getf (getf result :checks) :semantic))))
|
||||
|
||||
(test unified-structural-failure
|
||||
(let ((result (opencortex::lisp-validator-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (eq (getf result :failed) :structural))))
|
||||
|
||||
(test unified-semantic-failure-strict
|
||||
(let ((result (opencortex::lisp-validator-validate "(delete-file \"x.txt\")" :strict t)))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (eq (getf result :failed) :semantic))))
|
||||
Reference in New Issue
Block a user