passepartout: v0.4.3 Shell Sandboxing & Safety Classification
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 3s

- bwrap sandbox: detect bwrap binary, wrap shell commands through
  Linux namespace isolation with --unshare-net --unshare-ipc
  when available, fall back to timeout bash -c otherwise
- Severity classification: extend shell-blocked patterns with
  :catastrophic/:dangerous/:moderate/:harmless severity tiers,
  dispatcher-severity-max for tier comparison
- dispatcher-check-shell-safety: returns (:matched <names> :severity <tier>)
- Version: 0.4.2 -> 0.4.3 across handshake, ASDF, README badge
This commit is contained in:
2026-05-07 17:52:32 -04:00
parent 791a0f9c3b
commit eeb1234086
10 changed files with 313 additions and 64 deletions

View File

@@ -151,7 +151,7 @@ The daemon sends a handshake message on connection, then enters a read loop, inj
(let ((stream (usocket:socket-stream socket)))
(handler-case
(progn
(format stream "~a" (frame-message (make-hello-message "0.4.2")))
(format stream "~a" (frame-message (make-hello-message "0.4.3")))
(finish-output stream)
(loop
(let ((msg (read-framed-message stream)))

View File

@@ -22,7 +22,7 @@ Components are loaded in sequence (~:serial t~): package first (defines the publ
(defsystem :passepartout
:name "Passepartout"
:author "Amr Gharbeia"
:version "0.4.2"
:version "0.4.3"
:license "AGPLv3"
:description "The Probabilistic-Deterministic Lisp Machine"
:depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid)

View File

@@ -32,9 +32,9 @@ The Dispatcher also handles the **Flight Plan** system: when a high-risk action
2. (dispatcher-check-secret-path filepath): returns the matching
protected pattern if ~filepath~ matches any entry in
~*dispatcher-protected-paths*~, nil otherwise.
3. (dispatcher-check-shell-safety cmd): returns a list of matched
dangerous-pattern names if ~cmd~ triggers any entry in
~*dispatcher-shell-blocked*~, nil if safe.
3. (dispatcher-check-shell-safety cmd): returns ~(:matched <names> :severity <tier>)~
if ~cmd~ triggers any entry in ~*dispatcher-shell-blocked*~, nil if safe.
Severity tiers: ~:catastrophic~ > ~:dangerous~ > ~:moderate~ > ~:harmless~.
4. (dispatcher-check-privacy-tags tags-list): returns T if any tag in
~tags-list~ matches a privacy filter tag, nil otherwise.
5. (dispatcher-check-network-exfil cmd): returns T (unsafe) if ~cmd~
@@ -141,15 +141,16 @@ Destructive and injection patterns that are blocked in shell commands. Covers ~r
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(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.")
'((: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.")
#+end_src
** Secret Path Check (dispatcher-check-secret-path)
@@ -329,15 +330,35 @@ Returns the validation result plist or nil if not applicable."
#+begin_src lisp
(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."
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))
(let ((matches nil)
(severity :harmless))
(dolist (entry *dispatcher-shell-blocked*)
(let ((name (first entry))
(regex (second entry)))
(regex (second entry))
(tier (getf entry :severity)))
(when (cl-ppcre:scan regex cmd)
(push name matches))))
matches)))
(push name matches)
(setf severity (dispatcher-severity-max severity (or tier :moderate))))))
(when matches
(list :matched matches :severity severity)))))
#+end_src
** Severity Comparison (dispatcher-severity-max)
;; REPL-VERIFIED: 2026-05-07T17:00:00
#+begin_src lisp
(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)))
#+end_src
** Network Check (dispatcher-check-network-exfil)
@@ -707,6 +728,31 @@ Recognized formats:
(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:")))

View File

@@ -13,32 +13,81 @@ Because shell execution is the highest-risk operation in the system, the Shell A
3. The Dispatcher's network exfil gate blocks connections to unwhitelisted hosts
4. The actuator enforces a timeout (default 30s) so hanging commands don't freeze the agent
5. The actuator caps output (default 100KB) so infinite output doesn't exhaust memory
6. (v0.4.3) When ~bwrap~ (Bubblewrap) is available, commands execute inside a Linux namespace sandbox with network and IPC isolation
** Contract
1. (bwrap-available-p): returns T if ~bwrap~ is installed and usable, NIL otherwise.
Cached at load time via ~which bwrap~.
2. (bwrap-wrap-command cmd timeout memex-dir): returns a command list suitable for
~uiop:run-program~ — wraps ~cmd~ in a ~bwrap~ sandbox with ~--unshare-net~,
~--unshare-ipc~, ~--ro-bind~ for system dirs, and ~--bind~ for the memex and /tmp.
3. (actuator-shell-execute action context): when ~bwrap~ is available, wraps the
command through the sandbox. When ~bwrap~ is unavailable, falls back to the
existing ~timeout bash -c~ behavior.
* Implementation
** Shell Execution (actuator-shell-execute)
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(in-package :passepartout)
(defvar *bwrap-available* nil
"Set to T at load time if the bwrap binary is found in PATH.")
(defvar *bwrap-base-args*
'("--ro-bind" "/usr" "/usr"
"--ro-bind" "/lib" "/lib"
"--ro-bind" "/bin" "/bin"
"--ro-bind" "/etc" "/etc"
"--bind" "/tmp" "/tmp"
"--unshare-net"
"--unshare-ipc")
"Base bwrap arguments for the sandbox. --bind ~/memex ~/memex is added dynamically.")
(defun bwrap-available-p ()
"Returns T if bwrap (bubblewrap) is installed and usable."
*bwrap-available*)
(defun bwrap-wrap-command (cmd timeout memex-dir)
"Wrap CMD in a bwrap sandbox with network and IPC isolation.
Returns a list suitable for uiop:run-program."
`("bwrap"
,@*bwrap-base-args*
"--bind" ,memex-dir ,memex-dir
"timeout" ,(format nil "~a" timeout)
"bash" "-c" ,cmd))
;; Initialize at load time
(setf *bwrap-available*
(= 0 (nth-value 2 (uiop:run-program '("which" "bwrap") :output nil :error-output nil :ignore-error-status t))))
(defun actuator-shell-execute (action context)
"Executes a shell command via the OS timeout binary with output limit."
"Executes a shell command via the OS timeout binary with output limit.
When bwrap is available, wraps the command in a Linux namespace sandbox."
(declare (ignore context))
(let* ((payload (getf action :payload))
(cmd (getf payload :cmd))
(timeout-sym (find-symbol "*DISPATCHER-SHELL-TIMEOUT*" :passepartout))
(timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30)))
(max-sym (find-symbol "*DISPATCHER-SHELL-MAX-OUTPUT*" :passepartout))
(max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000))))
(log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout)
(multiple-value-bind (out err code)
(uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)
:output :string :error-output :string
:ignore-error-status t)
(cond
((= code 124) (format nil "ERROR: Command timed out after ~a seconds" timeout))
((> (length out) max-output)
(format nil "~a~%... (output truncated to ~a chars)" (subseq out 0 max-output) max-output))
((= code 0) out)
(t (format nil "ERROR [~a]: ~a" code err))))))
(max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000)))
(memex-dir (or (uiop:getenv "MEMEX_DIR") (namestring (merge-pathnames "memex/" (user-homedir-pathname))))))
(log-message "ACT [Shell]: ~a (timeout: ~as)~@[ bwrap: enabled~]" cmd timeout (and *bwrap-available* " (bwrap)"))
(let ((cmdline (if *bwrap-available*
(bwrap-wrap-command cmd timeout memex-dir)
(list "timeout" (format nil "~a" timeout) "bash" "-c" cmd))))
(multiple-value-bind (out err code)
(uiop:run-program cmdline
:output :string :error-output :string
:ignore-error-status t)
(cond
((= code 124) (format nil "ERROR: Command timed out after ~a seconds" timeout))
((> (length out) max-output)
(format nil "~a~%... (output truncated to ~a chars)" (subseq out 0 max-output) max-output))
((= code 0) out)
(t (format nil "ERROR [~a]: ~a" code err)))))))
#+end_src
** Skill Registration
@@ -49,3 +98,38 @@ Because shell execution is the highest-risk operation in the system, the Shell A
:priority 50
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
#+end_src
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-shell-actuator-tests
(:use :cl :fiveam :passepartout)
(:export #:shell-actuator-suite))
(in-package :passepartout-shell-actuator-tests)
(def-suite shell-actuator-suite :description "Verification of the Shell Actuator")
(in-suite shell-actuator-suite)
(test test-bwrap-wrap-command
"Contract 2: bwrap-wrap-command returns properly formatted command list."
(let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex")))
(is (member "bwrap" cmdline :test #'string=))
(is (member "--unshare-net" cmdline :test #'string=))
(is (member "--unshare-ipc" cmdline :test #'string=))
(is (member "echo hello" cmdline :test #'string=))))
(test test-bwrap-available-p-returns-boolean
"Contract 1: bwrap-available-p returns T or NIL."
(let ((avail (passepartout::bwrap-available-p)))
(is (typep avail 'boolean))))
(test test-actuator-shell-execute-echo
"Contract 3: actuator-shell-execute runs echo and returns output."
(let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello")))
(result (passepartout::actuator-shell-execute action nil)))
(is (stringp result))
(is (search "hello" result :test #'char-equal))))
#+end_src