v0.8.0: Information Radiator, Command Palette, TrueColor Themes, Setup Wizard
- Sidebar: permanent 42-col panel with 7 data panels (Gate Trace, Focus, Rules, Context gauge, Files, Cost, Protection); 4-window Croatoan layout at >=120 cols, toggle via Ctrl+X+B - Command palette: Ctrl+P overlay with fuzzy-filtered categorized items, keyboard navigation, Enter to execute; view-palette rendering - TrueColor themes: 4 new presets (nord, tokyonight, catppuccin, monokai) with 27 hex keys via theme-hex-to-rgb - Setup wizard: Ctrl+\ /setup 4-step overlay (provider, key, memory, save) writing .env with in-TUI rendering - Daemon enrichment: dispatcher block counts, cost session summary, modified files tracking, context usage percentage - Daemon fixes: fboundp guards for count-tokens/provider-token-cost, tool registry save/restore in safety tests, SELF_BUILD_MODE cleanup - 139 tests pass across all suites (0 failures)
This commit is contained in:
@@ -290,54 +290,60 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
|
||||
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)))))
|
||||
((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)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath)))))
|
||||
;; 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)
|
||||
(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 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)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "Action blocked: Content contains potential secret exposure."))))
|
||||
;; 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)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
|
||||
;; 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)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
|
||||
((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)
|
||||
@@ -345,36 +351,40 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
|
||||
(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")
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text "Action blocked: Text may reference private content.")))
|
||||
;; 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)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
|
||||
;; 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.")
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :sensor :approval-required :action action)))
|
||||
;; 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 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)))
|
||||
;; 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 ()
|
||||
@@ -496,6 +506,25 @@ Recognized formats:
|
||||
: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)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -594,7 +623,7 @@ Recognized formats:
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :warn (passepartout::tag-category-severity "@draft")))
|
||||
(is (eq :log (passepartout::tag-category-severity "@review"))))
|
||||
(setf (uiop:getenv "TAG_CATEGORIES") nil))
|
||||
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
|
||||
|
||||
(test test-tag-category-severity-unknown
|
||||
"Contract v0.7.2: unknown tag returns nil."
|
||||
@@ -661,20 +690,51 @@ Recognized formats:
|
||||
|
||||
(test test-safe-tool-write-still-checked
|
||||
"Contract v0.7.2: write tools still go through full dispatcher check."
|
||||
(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)))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (search "HITL" (getf (getf result :payload) :message)))))
|
||||
(remhash "write-file" passepartout::*cognitive-tool-registry*)))
|
||||
(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-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)))))
|
||||
|
||||
Reference in New Issue
Block a user