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*)