Rebuild (sigil system grant) as a profile over (sigil grant)

Message

The table's fs-entries/exec/pty slots become one immutable (sigil grant) value; the module keeps the principal, the decision audit log, and the canonicalisation the algebra cannot have. Public API is unchanged and the 16 internal call sites in fs/process/session/proof are untouched.

DELETED, not adapted: path-under?, the component-safe prefix test. It is component-prefix-covers? in the algebra now, parameterised on its separator, and property-tested there. Also gone: the argv[0]-exact member check, and the hand-written "unless the existing exec is 'full" special case that stopped a later allowlist downgrading exec:full -- that now falls out of the algebra's scalar-kind merge rather than being a rule this module remembers to apply.

KEPT: realpath at construction and canonical-target at check time. Those are the profile's whole reason to exist. The algebra is pure because the browser target has no filesystem; resolving a path against the real one is the check site's job, and this is the check site. realpath also normalises away '.', '..' and relative prefixes, which is exactly what the algebra requires and refuses to do itself.

The check site asks facet-permits? against the grant's facets rather than building a probe grant and calling grant-covers?, and the difference matters here: make-grant RAISES on a resource it considers unconstructible, while facet-permits? is total and fail-closed and DENIES. A check handed a hostile argv[0] must return #f, not throw -- a caller that guards the check and reads "no #f" as a pass would treat a raise as permitted.

grant-add! deliberately accepts a NARROWER grammar than the algebra: fs, exec and pty only. (sigil grant) also parses net/import/eval/ffi, and storing one of those here would record authority nothing in this library ever consults -- a rule that grants nothing, sitting in a config looking like it grants something.

NOT LANDABLE YET: package.sgl still says sigil: "^0.17", and (sigil grant) needs the release that ships it. That one field is the only thing gating this branch.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_01DYn8wxSdjveEgK9NRxFcNA

Changed

 src/sigil/system/grant.sgl | 183 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------------------------------------------------------------------
 1 file changed, 107 insertions(+), 76 deletions(-)

Diff

src/sigil/system/grant.sglmodified

@@ -1,4 +1,4 @@

−1

;;; (sigil system grant) - Capability Grant Engine

;;; (sigil system grant) - Capability Grant Engine (system profile)

;;;

;;; The deny-by-default scoping policy that guards every capability entry

;;; point in this library. A grants table declares what a principal may

@@ -10,6 +10,28 @@

;;; while a remote node runs `make-grants` plus explicit grant entries

;;; (deny-by-default). Enforcement logic is identical in both.

;;;

+13

;;; ## This module is a PROFILE over `(sigil grant)`, not a second engine

+14

;;;

+15

;;; The grant value, the facet grammar, the partial order and the

+16

;;; attenuation meet all live in `(sigil grant)` in the standard library.

+17

;;; This module is the OS-facing profile on top of it, and it owns

+18

;;; exactly three things the pure algebra cannot have:

+19

;;;

+20

;;; 1. **Canonicalisation.** `realpath` at construction, so a grant is

+21

;;; anchored to a real directory; and `realpath` at check time, so a

+22

;;; symlink cannot escape an allowed root. The algebra is pure and

+23

;;; compares patterns structurally — it has no filesystem, by design,

+24

;;; because the browser/wasm target has none.

+25

;;; 2. **The principal** a table is scoped to.

+26

;;; 3. **The decision audit log.**

+27

;;;

+28

;;; What USED to live here and now does not: the component-safe prefix

+29

;;; test (`/a/bc` is not under `/a/b`), the argv[0]-exact exec match, and

+30

;;; the rule that `exec:full` is not downgraded by a later allowlist.

+31

;;; All three are now properties of the algebra — the last one falls out

+32

;;; of its scalar-kind merge rather than being a hand-written special

+33

;;; case — and all three are property-tested there.

+34

;;;

;;; ## Grant specs

;;;

;;; Grants are added with compact spec strings (the same grammar a node

@@ -34,6 +56,15 @@

;;; (grant-assert! g 'exec "rm") ; raises

;;; ```

;;;

+59

;;; **This profile deliberately accepts a NARROWER spec grammar than

+60

;;; `(sigil grant)` does.** The algebra also understands `net`, `import`,

+61

;;; `eval` and `ffi`, and this module refuses them — because it does not

+62

;;; ENFORCE them. Storing a grant nothing ever checks would put a rule

+63

;;; that grants nothing into a config where it looks like it grants

+64

;;; something, which is a worse failure than a refusal. When enforcement

+65

;;; for a kind arrives here, its spec form is admitted in the same

+66

;;; change.

+67

;;;

;;; Paths are canonicalized (symlinks resolved) before checking, so a

;;; symlink escaping an allowed root is denied. Every decision is

;;; recorded in an in-memory audit log (`grant-decisions`); a durable

@@ -44,6 +75,8 @@

(import (sigil fs)

(sigil path)

(sigil string)

+78

(sigil list)

+79

(sigil grant)

(sigil time))

(export

@@ -65,15 +98,19 @@

(begin

100

−68

;; Grants are a small mutable table:

−69

;; (vector 'grants principal fs-entries exec pty decisions)

−70

;; fs-entries: list of (mode . canonical-root), mode in {ro rw}

−71

;; exec: 'off | 'full | list of allowed command names

−72

;; pty: boolean

−73

;; decisions: reverse-chronological list of decision dicts

+101

;; A grants table is a small mutable box around an IMMUTABLE

+102

;; (sigil grant) value:

+103

;;

+104

;; (vector 'grants principal <grant> decisions)

+105

;;

+106

;; The table is mutable because `grant-add!` is part of this module's

+107

;; established API; the authority inside it is not. Every add

+108

;; REPLACES the grant with a new one rather than mutating a list of

+109

;; entries, so an authority value handed to anything else cannot be

+110

;; changed underneath it.

111

−75

(define (make-grants-vector principal fs-entries exec pty)

−76

(vector 'grants principal fs-entries exec pty '()))

+112

(define (make-grants-vector principal g)

+113

(vector 'grants principal g '()))

114

115

;;; Create an empty, deny-by-default grants table.

116

;;;

@@ -83,13 +120,19 @@

120

;;; ```

121

(define (make-grants (keys: (principal "owner")))

122

(: (principal: string?) -> any?)

−86

(make-grants-vector principal '() 'off #f))

+123

(make-grants-vector principal (empty-grant)))

124

125

;;; Create a fully permissive grants table (the in-process owner

126

;;; posture: the embedding application is the user's own).

+127

;;;

+128

;;; Note this is the top of the THREE KINDS THIS PROFILE ENFORCES,

+129

;;; not the algebra's `(grant-allow-all)`, which is the top of all

+130

;;; seven. Granting kinds nothing here checks would be authority

+131

;;; recorded and never consulted.

132

(define (grant-allow-all (keys: (principal "owner")))

133

(: (principal: string?) -> any?)

−92

(make-grants-vector principal (list (cons 'rw "/")) 'full #t))

+134

(make-grants-vector principal

+135

(make-grant '((fs rw "/") (exec full #f) (pty on #f)))))

136

137

;;; Check if a value is a grants table.

138

(define (grants? obj)

@@ -103,32 +146,38 @@

146

(: any? -> string?)

147

(vector-ref g 1))

148

−106

(define (grants-fs-entries g) (vector-ref g 2))

−107

(define (grants-exec g) (vector-ref g 3))

−108

(define (grants-pty g) (vector-ref g 4))

−109

(define (set-grants-fs-entries! g v) (vector-set! g 2 v))

−110

(define (set-grants-exec! g v) (vector-set! g 3 v))

−111

(define (set-grants-pty! g v) (vector-set! g 4 v))

+149

;; The immutable authority value this table currently holds.

+150

(define (grants-grant g) (vector-ref g 2))

+151

(define (set-grants-grant! g v) (vector-set! g 2 v))

152

153

;;; The decision audit log, most recent first. Each entry is a dict:

154

;;; `#{ op: fs-read stream detail: "/path" allowed: #t at: <seconds> }`.

155

(define (grant-decisions g)

156

(: any? -> list?)

−117

(vector-ref g 5))

+157

(vector-ref g 3))

158

159

(define (record-decision! g op detail allowed)

−120

(vector-set! g 5

+160

(vector-set! g 3

161

(cons (dict op: op

162

detail: detail

163

allowed: allowed

164

at: (current-second))

−125

(vector-ref g 5)))

+165

(vector-ref g 3)))

166

allowed)

167

168

;; ============================================================

169

;; Adding grants

170

;; ============================================================

171

+172

;; Add one facet to the table's grant. `make-grant` re-normalises,

+173

;; which is where `exec:full` absorbing a later allowlist now comes

+174

;; from — the algebra's scalar-kind merge, rather than the

+175

;; hand-written "unless the existing exec is 'full" special case this

+176

;; module used to carry.

+177

(define (add-facet! g facet)

+178

(set-grants-grant! g

+179

(make-grant (cons facet (grant-facets (grants-grant g))))))

+180

181

;;; Add a grant to the table from a spec string.

182

;;;

183

;;; Spec grammar: `fs:ro:<path>`, `fs:rw:<path>`,

@@ -139,7 +188,15 @@

188

(: any? string? -> void?)

189

(let ((parts (string-split spec ":")))

190

(cond

−142

;; fs:ro:<path> / fs:rw:<path> — path may itself contain ':'

+191

;; fs:ro:<path> / fs:rw:<path> — path may itself contain ':'.

+192

;;

+193

;; THIS BRANCH IS WHY THIS MODULE STILL EXISTS. The algebra

+194

;; cannot canonicalise: it is pure, and the browser target has

+195

;; no filesystem. So the profile resolves the path HERE and

+196

;; hands the algebra a canonical, existing, absolute root.

+197

;; `realpath` also normalises away `.`, `..` and any relative

+198

;; prefix, which is exactly what the algebra requires and

+199

;; refuses to do itself.

200

((and (>= (length parts) 3)

201

(string=? (car parts) "fs"))

202

(let ((mode (cadr parts))

@@ -149,34 +206,15 @@

206

(let ((root (realpath path)))

207

(unless root

208

(error "grant-add!: fs grant path does not exist" path))

−152

(set-grants-fs-entries! g

−153

(cons (cons (if (string=? mode "rw") 'rw 'ro) root)

−154

(grants-fs-entries g))))))

−155

−156

;; exec:full

−157

((and (= (length parts) 2)

−158

(string=? (car parts) "exec")

−159

(string=? (cadr parts) "full"))

−160

(set-grants-exec! g 'full))

−161

−162

;; exec:allowlist:<cmd>,<cmd>

−163

((and (= (length parts) 3)

−164

(string=? (car parts) "exec")

−165

(string=? (cadr parts) "allowlist"))

−166

(let ((cmds (string-split (caddr parts) ","))

−167

(existing (grants-exec g)))

−168

;; 'full is strictly more permissive than any allowlist, so

−169

;; adding an allowlist entry on top of full must NOT downgrade

−170

;; the grant to that bounded list.

−171

(unless (eq? existing 'full)

−172

(set-grants-exec! g

−173

(append cmds (if (pair? existing) existing '()))))))

+209

(add-facet! g (list 'fs (if (string=? mode "rw") 'rw 'ro) root)))))

210

−175

;; pty:on

−176

((and (= (length parts) 2)

−177

(string=? (car parts) "pty")

−178

(string=? (cadr parts) "on"))

−179

(set-grants-pty! g #t))

+211

;; The kinds this profile ENFORCES are the only ones it admits.

+212

;; `spec->facet` would also accept net/import/eval/ffi, and

+213

;; storing one of those here would record authority that

+214

;; nothing in this library ever consults.

+215

((or (string=? (car parts) "exec")

+216

(string=? (car parts) "pty"))

+217

(add-facet! g (spec->facet spec)))

218

219

(else

220

(error "grant-add!: malformed grant spec" spec)))))

@@ -196,39 +234,32 @@

234

(and parent

235

(path-join parent (path-basename path)))))))

236

−199

;; Is p equal to root, or strictly under it? Component-safe:

−200

;; "/a/bc" is NOT under "/a/b".

−201

(define (path-under? root p)

−202

(or (string=? p root)

−203

(if (string=? root "/")

−204

(string-starts-with? p "/")

−205

(string-starts-with? p (string-append root "/")))))

+237

;; Does the table's authority permit this facet?

+238

;;

+239

;; Asked through `facet-permits?` against the grant's own facets

+240

;; rather than by building a probe grant and calling `grant-covers?`,

+241

;; and the difference is load-bearing at a CHECK site: `make-grant`

+242

;; RAISES on a resource it considers unconstructible (a command

+243

;; containing a comma, say), while `facet-permits?` is total and

+244

;; fail-closed and DENIES it. A check handed a hostile argv[0] must

+245

;; return #f, not throw — a caller that guards the check and treats

+246

;; "no #f" as a pass would read a raise as permitted.

+247

(define (permits? g facet)

+248

(list-any? (lambda (f) (facet-permits? f facet))

+249

(grant-facets (grants-grant g))))

250

251

(define (fs-allowed? g path for-write?)

252

(let ((target (canonical-target path for-write?)))

253

(and target

−210

(let loop ((entries (grants-fs-entries g)))

−211

(cond

−212

((null? entries) #f)

−213

((and (path-under? (cdr (car entries)) target)

−214

(or (not for-write?)

−215

(eq? (car (car entries)) 'rw)))

−216

#t)

−217

(else (loop (cdr entries))))))))

+254

(permits? g (list 'fs (if for-write? 'rw 'ro) target)))))

255

+256

;; argv[0] is matched EXACTLY by the algebra's exec facet: an

+257

;; allowlist entry "git" permits argv[0] "git" and NOT

+258

;; "/tmp/evil/git", i.e. any attacker-controlled binary of the same

+259

;; name. To allow an absolute path, grant that exact path.

260

(define (exec-allowed? g command)

−220

(let ((exec (grants-exec g)))

−221

(cond

−222

((eq? exec 'full) #t)

−223

((pair? exec)

−224

;; Match argv[0] EXACTLY against the allowlist. Matching on the

−225

;; basename would be a hole: an allowlist entry "git" would then

−226

;; also permit "/tmp/evil/git", i.e. any attacker-controlled

−227

;; binary of the same name. So "git" allows only argv[0] = "git"

−228

;; (resolved via PATH); to allow an absolute path, grant that

−229

;; exact path.

−230

(if (member command exec) #t #f))

−231

(else #f))))

+261

(and (string? command)

+262

(permits? g (list 'exec 'allowlist (list command)))))

263

264

;;; Check whether an operation is allowed. Records the decision in

265

;;; the audit log and returns a boolean.

@@ -242,7 +273,7 @@

273

((fs-read) (fs-allowed? g detail #f))

274

((fs-write) (fs-allowed? g detail #t))

275

((exec) (exec-allowed? g detail))

−245

((pty) (grants-pty g))

+276

((pty) (permits? g '(pty on #f)))

277

(else #f))))

278

279

;;; Like `grant-check`, but raises a `grant-denied` error when the