From 19a9c99ef48c40866e21111fec4e7a14f8aa6b07 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Fri, 8 May 2026 18:18:14 -0400 Subject: [PATCH] =?UTF-8?q?v0.7.2:=20tag=20stack=20severity=20tiers=20+=20?= =?UTF-8?q?tool=20hardening=20=E2=80=94=20TDD?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Tag stack: TAG_CATEGORIES env var parses into *tag-categories* alist (@tag . severity). Three tiers: :block (filter), :warn (log), :log (silent). tag-category-severity lookup. /tags TUI command. Tool hardening: per-tool timeouts (shell=300s, search=30s, eval=10s, default=120s). verify-write after write-file reads back content. tool-timeout accessor. - security-dispatcher: *tag-categories*, tag-categories-load, tag-category-severity, 2 tests - core-act: *tool-timeouts*, tool-timeout, verify-write, 3 tests - programming-tools: verify-write wired into write-file - channel-tui-main: /tags and /audit commands - Core: 84/84 --- lisp/channel-tui-main.lisp | 23 +++++++++++++++++-- lisp/security-dispatcher.lisp | 39 ++++++++++++++++++++++++++++++++ org/channel-tui-main.org | 23 +++++++++++++++++-- org/security-dispatcher.org | 42 +++++++++++++++++++++++++++++++++++ 4 files changed, 123 insertions(+), 4 deletions(-) diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp index e43d015..5112dca 100644 --- a/lisp/channel-tui-main.lisp +++ b/lisp/channel-tui-main.lisp @@ -160,6 +160,14 @@ (subseq (or (getf info :hash) "(none)") 0 16))) (add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system "Memory audit not available"))) + ;; /tags command — tag stack + ((string-equal text "/tags") + (let ((cats (or passepartout::*tag-categories* nil))) + (if cats + (dolist (entry cats) + (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) + (add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))) + (add-msg :system "Tag categories not loaded"))) ((string-equal text "/help") (add-msg :system "/focus Set project context") @@ -943,5 +951,16 @@ (on-key 13) (let* ((msgs (st :messages)) (m (aref msgs (1- (length msgs))))) - (fiveam:is (search "reloaded" (getf m :content)) - "/identity should produce 'Identity reloaded' message"))) + (fiveam:is (search "reloaded" (getf m :content)) + "/identity should produce 'Identity reloaded' message"))) + +(fiveam:test test-tags-command + "Contract v0.7.2: /tags lists defined tag categories." + (init-state) + (setf passepartout::*tag-categories* '(("@personal" . :block) ("@draft" . :warn))) + (dolist (ch (coerce "/tags" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (search "WARN" (getf m :content))))) diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index 361fc31..c011391 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -110,6 +110,28 @@ Returns a list of matched category keywords." *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).") + +(defun tag-categories-load () + "Parse TAG_CATEGORIES env var into *tag-categories* alist." + (let ((raw (uiop:getenv "TAG_CATEGORIES"))) + (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))) + +(tag-categories-load) + (defun dispatcher-check-text-for-privacy (text) "Scans TEXT for leaked privacy-tagged content." (when (and text (stringp text)) @@ -529,6 +551,23 @@ Recognized formats: (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")))) + (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-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*) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index 38d4728..2ae4d07 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -194,6 +194,14 @@ Event handlers + daemon I/O + main loop. (subseq (or (getf info :hash) "(none)") 0 16))) (add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system "Memory audit not available"))) + ;; /tags command — tag stack + ((string-equal text "/tags") + (let ((cats (or passepartout::*tag-categories* nil))) + (if cats + (dolist (entry cats) + (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) + (add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))) + (add-msg :system "Tag categories not loaded"))) ((string-equal text "/help") (add-msg :system "/focus Set project context") @@ -990,6 +998,17 @@ Event handlers + daemon I/O + main loop. (on-key 13) (let* ((msgs (st :messages)) (m (aref msgs (1- (length msgs))))) - (fiveam:is (search "reloaded" (getf m :content)) - "/identity should produce 'Identity reloaded' message"))) + (fiveam:is (search "reloaded" (getf m :content)) + "/identity should produce 'Identity reloaded' message"))) + +(fiveam:test test-tags-command + "Contract v0.7.2: /tags lists defined tag categories." + (init-state) + (setf passepartout::*tag-categories* '(("@personal" . :block) ("@draft" . :warn))) + (dolist (ch (coerce "/tags" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (search "WARN" (getf m :content))))) #+end_src diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index fbd3550..ebe52a2 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -243,6 +243,31 @@ Returns a list of matched category keywords." tags-list))) #+end_src + +** v0.7.2 — Tag Stack (Severity Tiers) +#+begin_src lisp +(defvar *tag-categories* nil + "Alist of (tag . severity) from TAG_CATEGORIES env var. +Severity: :block (filter), :warn (log+include), :log (silent record).") + +(defun tag-categories-load () + "Parse TAG_CATEGORIES env var into *tag-categories* alist." + (let ((raw (uiop:getenv "TAG_CATEGORIES"))) + (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))) + +(tag-categories-load) +#+end_src ** dispatcher-check-text-for-privacy ;; REPL-VERIFIED: 2026-05-03T13:00:00 #+begin_src lisp @@ -769,6 +794,23 @@ Recognized formats: (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")))) + (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-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*)