Amr Gharbeia
d35aea391e
- New system-event-orchestrator skill with hook registry, cron registry, and tier classifier - Three dispatch tiers: :reflex (no LLM), :cognition (light), :reasoning (full) - Org-mode timestamp parsing for repeat patterns (+1w, +1d, +1m) - Registers on heartbeat via defskill, dispatches due cron jobs - Fix all remaining harness-log → log-message references across org files
328 lines
15 KiB
Common Lisp
328 lines
15 KiB
Common Lisp
(defvar *dispatcher-network-whitelist*
|
|
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
|
|
"Domains the Bouncer 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.")
|
|
|
|
(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-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 "BOUNCER: ~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 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 :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)))
|
|
(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 (list-objects-with-attribute :TODO "APPROVED"))
|
|
(found-any nil))
|
|
(dolist (node approved-nodes)
|
|
(let* ((attrs (org-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 "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node))
|
|
(let ((action (ignore-errors (read-from-string action-str))))
|
|
(when action
|
|
(setf (getf action :approved) t)
|
|
(inject-stimulus action)
|
|
(setf (getf (org-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."
|
|
(let ((id (org-id-new)))
|
|
(log-message "BOUNCER: 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))))))
|
|
|
|
(defun dispatcher-gate (action context)
|
|
"Main deterministic gate for the Bouncer 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)
|