security: lint capability overgrants

Jaime Fournier <jaimef@linbsd.org>

13238b975e98a6291345a018273b80372ef7382a

diff --git a/Makefile b/Makefile
index 1c05b47..6c56754 100644
--- a/Makefile
+++ b/Makefile
@@ -375,6 +375,9 @@ capability-plan:
 .PHONY: capability-use-check
 capability-use-check:
 	@$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-capability-use.ss .jerboa-system
+	@$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-capability-use.ss tests/fixtures/capability-use/audited-boundary.sexp >/dev/null
+	@if $(SCHEME) --libdirs $(LIBDIRS) --script tools/check-capability-use.ss tests/fixtures/capability-use/overgrant.sexp >/dev/null 2>&1; then echo "expected capability overgrant fixture to fail"; exit 1; fi
+	@if $(SCHEME) --libdirs $(LIBDIRS) --script tools/check-capability-use.ss tests/fixtures/capability-use/unaudited-boundary.sexp >/dev/null 2>&1; then echo "expected unaudited capability boundary fixture to fail"; exit 1; fi
 
 .PHONY: native-boundary-check
 native-boundary-check:
diff --git a/data/anti-patterns.sexp b/data/anti-patterns.sexp
index bb02985..f1c80c9 100644
--- a/data/anti-patterns.sexp
+++ b/data/anti-patterns.sexp
@@ -5262,4 +5262,25 @@
    ("tools"
      "jerboa_make"
      "jerboa_verify"
-     "jerboa_check_balance")))
+     "jerboa_check_balance"))
+ (("advice"
+    .
+    "When extending static grant lint, add domain-specific patterns for boundary calls first, then test both audited positive fixtures and unaudited/overgrant negative fixtures.")
+   ("avoid"
+     .
+     "Do not add overgrant detection without also attributing explicit boundary checks to the affected capability domain.")
+   ("id" . "scanner-boundary-without-domain-attribution")
+   ("kinds" "security" "static-analysis" "lint")
+   ("pattern"
+     .
+     "A capability-use scanner detects OS sink calls for domain use but treats boundary checks such as check-capability! only as policy violations, so a valid audited boundary can also look like a declared-but-unused overgrant.")
+   ("severity" . "medium")
+   ("tags" "security" "capabilities" "scanner" "overgrant"
+     "boundary")
+   ("title"
+     .
+     "Static scanner boundary calls must count as domain use")
+   ("tools"
+     "jerboa_check_balance"
+     "jerboa_security_scan"
+     "jerboa_make")))
diff --git a/docs/capability.md b/docs/capability.md
index 5d0a555..bef55c8 100644
--- a/docs/capability.md
+++ b/docs/capability.md
@@ -12,7 +12,10 @@ directory first, then from the current working directory. Grant at the latest
 practical moment, request the narrowest domain and permission set, attenuate
 before handing capabilities across module boundaries, and wrap boundary checks
 with `check-capability!/audit` from `(std security audit)` when the grant or
-denial must appear in the audit chain.
+denial must appear in the audit chain. The `capability-use-check` build target
+rejects undeclared capability use, declared-but-unused runtime domains, and
+direct `check-capability!` boundary checks in manifest source entries unless the
+boundary is audited or explicitly suppressed with a local security comment.
 
 ## Overview
 
diff --git a/docs/kimi3-security-recommmendations.md b/docs/kimi3-security-recommmendations.md
index cc682bc..fe41d34 100644
--- a/docs/kimi3-security-recommmendations.md
+++ b/docs/kimi3-security-recommmendations.md
@@ -748,16 +748,16 @@ they are build-time. Close the runtime loop.
   grant).
 - **Accept:** undeclared-grant refusal test; audit-chain verification
   test; lint rule fires on a synthetic over-grant.
-- **Status:** partially complete. `(std security capability)` now has an
-  active runtime grant plan via `with-capability-plan`; while bound, capability
-  constructors refuse undeclared grants with `&capability-violation`, and tests
-  cover declared grants plus undeclared filesystem/network refusals.
-  `load-capability-plan-file`/`with-capability-plan-file` load the conventional
-  `.jerboa/capabilities.sexp` policy file, and `jerboa run` binds that plan at
-  startup when found beside the script or in the current working directory. The
-  grant style guidance is documented in `capability.md` and the security
-  reference. Remaining work: require `check-capability!/audit` at selected
-  module boundaries and add the static over-grant lint.
+- **Status:** complete for the current capability-plan and static-checker
+  surface. `(std security capability)` now has an active runtime grant plan via
+  `with-capability-plan`; while bound, capability constructors refuse undeclared
+  grants with `&capability-violation`, and tests cover declared grants plus
+  undeclared filesystem/network refusals. `load-capability-plan-file` and
+  `with-capability-plan-file` load the conventional `.jerboa/capabilities.sexp`
+  policy file, and `jerboa run` binds that plan at startup when found beside the
+  script or in the current working directory. `capability-use-check` now rejects
+  undeclared capability use, synthetic over-grants, and direct unaudited
+  `check-capability!` boundary checks in manifest source entries.
 
 ### K3-P1-10 — Information-leak sweep: errors, logs, and protocol surfaces
 **Serves:** G2, G4. **Effort:** 1 week.
diff --git a/docs/security-reference.md b/docs/security-reference.md
index 8b370c7..fd628fa 100644
--- a/docs/security-reference.md
+++ b/docs/security-reference.md
@@ -267,6 +267,10 @@ Access rights are unforgeable tokens (sealed, opaque records with CSPRNG nonces)
   conventional `.jerboa/capabilities.sexp` application policy file. `jerboa run`
   binds that plan automatically when found beside the script or in the current
   working directory
+- **Static grant lint**: `make capability-use-check` rejects undeclared
+  capability-sensitive source use, declared-but-unused capability domains, and
+  direct `check-capability!` boundary checks in manifest source entries unless
+  they are audited through `check-capability!/audit` or carry a local suppression
 - **Thread-safe**: nonce generation is mutex-protected; capability context is a thread parameter
 
 ### Enforcement
diff --git a/tests/fixtures/capability-use/audited-boundary.sexp b/tests/fixtures/capability-use/audited-boundary.sexp
new file mode 100644
index 0000000..b81ba39
--- /dev/null
+++ b/tests/fixtures/capability-use/audited-boundary.sexp
@@ -0,0 +1,7 @@
+(system
+  (schema "jerboa.system/1")
+  (source
+    (entries ("tests/fixtures/capability-use/audited-boundary.ss")))
+  (capabilities
+    (filesystem
+      (read "."))))
diff --git a/tests/fixtures/capability-use/audited-boundary.ss b/tests/fixtures/capability-use/audited-boundary.ss
new file mode 100644
index 0000000..66978a6
--- /dev/null
+++ b/tests/fixtures/capability-use/audited-boundary.ss
@@ -0,0 +1,11 @@
+#!chezscheme
+(import (scheme)
+        (std security audit)
+        (std security capability))
+
+(define (boundary logger)
+  (check-capability!/audit logger
+                           (lambda ()
+                             (check-capability! 'filesystem 'read)) ; jerboa-security: suppress unaudited-capability-boundary -- enclosed by check-capability!/audit in this boundary fixture
+                           'capability/check
+                           '(domain . filesystem)))
diff --git a/tests/fixtures/capability-use/overgrant.sexp b/tests/fixtures/capability-use/overgrant.sexp
new file mode 100644
index 0000000..3a8bba7
--- /dev/null
+++ b/tests/fixtures/capability-use/overgrant.sexp
@@ -0,0 +1,7 @@
+(system
+  (schema "jerboa.system/1")
+  (source
+    (entries ("tests/fixtures/capability-use/pure.ss")))
+  (capabilities
+    (network
+      (connect "example.com"))))
diff --git a/tests/fixtures/capability-use/pure.ss b/tests/fixtures/capability-use/pure.ss
new file mode 100644
index 0000000..dcce8b6
--- /dev/null
+++ b/tests/fixtures/capability-use/pure.ss
@@ -0,0 +1,5 @@
+#!chezscheme
+(import (scheme))
+
+(define (pure-value)
+  42)
diff --git a/tests/fixtures/capability-use/unaudited-boundary.sexp b/tests/fixtures/capability-use/unaudited-boundary.sexp
new file mode 100644
index 0000000..f497fbd
--- /dev/null
+++ b/tests/fixtures/capability-use/unaudited-boundary.sexp
@@ -0,0 +1,7 @@
+(system
+  (schema "jerboa.system/1")
+  (source
+    (entries ("tests/fixtures/capability-use/unaudited-boundary.ss")))
+  (capabilities
+    (filesystem
+      (read "."))))
diff --git a/tests/fixtures/capability-use/unaudited-boundary.ss b/tests/fixtures/capability-use/unaudited-boundary.ss
new file mode 100644
index 0000000..352c39a
--- /dev/null
+++ b/tests/fixtures/capability-use/unaudited-boundary.ss
@@ -0,0 +1,6 @@
+#!chezscheme
+(import (scheme)
+        (std security capability))
+
+(define (boundary)
+  (check-capability! 'filesystem 'read))
diff --git a/tools/check-capability-use.ss b/tools/check-capability-use.ss
index 43955c1..c1ba872 100644
--- a/tools/check-capability-use.ss
+++ b/tools/check-capability-use.ss
@@ -13,21 +13,31 @@
       "(read-file" "(write-file" "(call-with-input-file"
       "(call-with-output-file" "(open-input-file" "(open-output-file"
       "(file-exists?" "(file-directory?" "(directory-list"
-      "(delete-file" "(current-directory")
+      "(delete-file" "(current-directory" "(check-capability! 'filesystem")
     (network
-      "(tcp-" "(udp-" "(socket" "(http-" "(request")
+      "(tcp-" "(udp-" "(socket" "(http-" "(request"
+      "(check-capability! 'network")
     (process
       "(system" "(open-process" "(open-process-ports" "(run-process"
-      "(fork" "(process")
+      "(fork" "(process" "(check-capability! 'process")
     (environment
-      "(getenv" "(putenv" "(environment-variables")
+      "(getenv" "(putenv" "(environment-variables"
+      "(check-capability! 'environment")
     (secrets
-      "(read-secret" "(secret-" "(yubikey" "(sign-secret")
+      "(read-secret" "(secret-" "(yubikey" "(sign-secret"
+      "(check-capability! 'secrets")
     (eval
       "(eval " "(eval\n" "(load " "(compile-file"
-      "(interaction-environment")
+      "(interaction-environment" "(check-capability! 'eval")
     (native
-      "(foreign-" "(load-shared-object" "(define-ftype" "(make-ftype-pointer")))
+      "(foreign-" "(load-shared-object" "(define-ftype"
+      "(make-ftype-pointer" "(check-capability! 'native")))
+
+(define policy-only-capability-domains '(package))
+(define audit-boundary-pattern "(check-capability!")
+(define audit-boundary-audit-pattern "(check-capability!/audit")
+(define audit-boundary-suppression
+  "jerboa-security: suppress unaudited-capability-boundary")
 
 (define (add-error msg) (set! errors (cons msg errors)))
 (define (add-warning msg) (set! warnings (cons msg warnings)))
@@ -128,6 +138,12 @@
                  (outer (cdr domains) (cons domain out))]
                 [else (inner (cdr ps))])))))))
 
+(define (unaudited-capability-boundary-line? line)
+  (let ([clean (line-without-comment line)])
+    (and (string-contains* clean audit-boundary-pattern)
+         (not (string-contains* clean audit-boundary-audit-pattern))
+         (not (string-contains* line audit-boundary-suppression)))))
+
 (define (scan-file path)
   (if (not (file-exists? path))
       (begin
@@ -144,13 +160,19 @@
         (let loop ([lines (read-lines path)] [line-no 1] [hits '()])
           (if (null? lines)
               hits
-              (let ([domains (domain-for-line (car lines))])
-                (loop (cdr lines)
-                      (+ line-no 1)
-                      (append
-                        (map (lambda (d) (list d path line-no))
-                             domains)
-                        hits))))))))
+              (let ([line (car lines)])
+                (when (unaudited-capability-boundary-line? line)
+                  (add-error
+                    (format "source uses unaudited capability boundary: ~a:~a"
+                            path
+                            line-no)))
+                (let ([domains (domain-for-line line)])
+                  (loop (cdr lines)
+                        (+ line-no 1)
+                        (append
+                          (map (lambda (d) (list d path line-no))
+                               domains)
+                          hits)))))))))
 
 (define (dedupe-symbols xs)
   (let loop ([rest xs] [out '()])
@@ -178,6 +200,24 @@
                     (loop (cdr children))
                     #t))])))))
 
+(define (declared-capability-domains caps)
+  (if (not caps)
+      '()
+      (let loop ([sections (cdr caps)] [out '()])
+        (cond
+          [(null? sections) (reverse out)]
+          [(and (valid-section? (car sections))
+                (domain-declared? caps (car (car sections))))
+           (loop (cdr sections) (cons (car (car sections)) out))]
+          [else (loop (cdr sections) out)]))))
+
+(define (policy-only-capability-domain? domain)
+  (memq domain policy-only-capability-domains))
+
+(define (capability-overgrant? used domain)
+  (and (not (memq domain used))
+       (not (policy-only-capability-domain? domain))))
+
 (define (check-manifest path)
   (let* ([manifest (read-one-form path)]
          [body (manifest-body manifest)]
@@ -186,19 +226,30 @@
          [entries (or (and source (section-value (cdr source) 'entries)) '())]
          [hits (apply append (map scan-file entries))]
          [used (dedupe-symbols (map car hits))]
+         [declared (declared-capability-domains caps)]
          [undeclared
-          (filter (lambda (domain) (not (domain-declared? caps domain))) used)])
+          (filter (lambda (domain) (not (domain-declared? caps domain))) used)]
+         [overgranted
+          (filter (lambda (domain) (capability-overgrant? used domain))
+                  declared)])
     (for-each
       (lambda (domain)
         (add-error
           (format "source uses undeclared or denied capability domain: ~a"
                   domain)))
       undeclared)
+    (for-each
+      (lambda (domain)
+        (add-error
+          (format "manifest declares unused capability domain: ~a" domain)))
+      overgranted)
     (display "capability-use:\n")
     (display "  manifest: ") (write path) (newline)
     (display "  scanned-entries: ") (write entries) (newline)
     (display "  used-domains: ") (write used) (newline)
+    (display "  declared-domains: ") (write declared) (newline)
     (display "  undeclared-domains: ") (write undeclared) (newline)
+    (display "  overgranted-domains: ") (write overgranted) (newline)
     (display "  finding-count: ") (write (length hits)) (newline)))
 
 (let ([path (parse-args (command-line-arguments))])