test/test-system.sgl — sigil-system

1;;; Tests for sigil-system: grant engine, fs capability, one-shot exec,

2;;; and the PTY session plane. The session tests ARE the S0 exit

3;;; criterion exercised end to end (open a pty, run a command, stream

4;;; output, resize, reap).

6(import (sigil test)

7 (sigil core)

8 (sigil io)

9 (sigil fs)

10 (sigil path)

11 (sigil process) ; getenv (fs-home tests)

12 (sigil string)

13 (sigil async)

14 (sigil channels)

15 (sigil system grant)

16 (sigil system fs)

17 (sigil system process)

18 (sigil system session))

20;; ============================================================

21;; Grant engine

22;; ============================================================

24(test-group "grant engine"

26 (test "deny by default"

27 (let ((g (make-grants)))

28 (assert-false (grant-check g 'pty #t))

29 (assert-false (grant-check g 'exec "ls"))

30 (assert-false (grant-check g 'fs-read "/etc/hosts"))))

32 (test "pty grant"

33 (let ((g (make-grants)))

34 (grant-add! g "pty:on")

35 (assert-true (grant-check g 'pty #t))))

37 (test "exec allowlist matches argv[0] exactly"

38 (let ((g (make-grants)))

39 (grant-add! g "exec:allowlist:ls,git")

40 (assert-true (grant-check g 'exec "ls"))

41 ;; Exact match only: a same-named binary at another path is NOT

42 ;; allowed (prevents an attacker-controlled /tmp/evil/ls bypass).

43 (assert-false (grant-check g 'exec "/tmp/evil/ls"))

44 (assert-false (grant-check g 'exec "rm"))))

46 (test "exec:full is not downgraded by a later allowlist"

47 (let ((g (make-grants)))

48 (grant-add! g "exec:full")

49 (grant-add! g "exec:allowlist:ls")

50 (assert-true (grant-check g 'exec "anything-still"))))

52 (test "exec full allows anything"

53 (let ((g (make-grants)))

54 (grant-add! g "exec:full")

55 (assert-true (grant-check g 'exec "anything"))))

57 (test "fs ro allows read not write"

58 (let ((g (make-grants)))

59 (grant-add! g "fs:ro:/tmp")

60 (assert-true (grant-check g 'fs-read "/tmp"))

61 (assert-false (grant-check g 'fs-write "/tmp/x"))))

63 (test "fs rw allows read and write under root"

64 (let ((g (make-grants)))

65 (grant-add! g "fs:rw:/tmp")

66 (assert-true (grant-check g 'fs-read "/tmp"))

67 (assert-true (grant-check g 'fs-write "/tmp/new-file"))))

69 (test "fs grant does not leak to sibling prefix"

70 (let ((g (make-grants))

71 (base (make-temp-directory)))

72 ;; /base/allow granted; /base/allowed must NOT be covered.

73 (make-directory (path-join base "allow"))

74 (make-directory (path-join base "allowed"))

75 (grant-add! g (string-append "fs:rw:" (path-join base "allow")))

76 (assert-true (grant-check g 'fs-write (path-join base "allow" "x")))

77 (assert-false (grant-check g 'fs-read (path-join base "allowed" "x")))))

79 (test "malformed spec raises"

80 (let ((g (make-grants)))

81 (assert-error (grant-add! g "nonsense"))))

83 (test "decisions are recorded"

84 (let ((g (make-grants)))

85 (grant-add! g "pty:on")

86 (grant-check g 'pty #t)

87 (grant-check g 'exec "ls")

88 (assert-equal (length (grant-decisions g)) 2)))

90 (test "allow-all posture"

91 (let ((g (grant-allow-all)))

92 (assert-true (grant-check g 'pty #t))

93 (assert-true (grant-check g 'exec "anything"))

94 (assert-true (grant-check g 'fs-read "/etc/hosts")))))

96;; ============================================================

97;; Filesystem capability

98;; ============================================================

100(test-group "fs capability"

101

102 (test "write then read a file"

103 (let ((g (make-grants))

104 (dir (make-temp-directory)))

105 (grant-add! g (string-append "fs:rw:" dir))

106 (let ((path (path-join dir "hello.txt")))

107 (fs-write-file g path "hi there\n")

108 (assert-equal (fs-read-file g path) "hi there\n"))))

109

110 (test "fs-home returns the home directory when granted"

111 ;; Exists so a client can expand "~" without hardcoding a host convention —

112 ;; on a remote node the home that matters is the NODE's, not the one typing.

113 (let ((g (make-grants))

114 (home (getenv "HOME")))

115 (grant-add! g (string-append "fs:ro:" home))

116 (assert-equal (fs-home g) (or (realpath home) home))))

117

118 (test "fs-home is DENIED to a principal scoped elsewhere"

119 ;; Grant-checked as a read OF home on purpose: a principal scoped to a project

120 ;; directory has no business learning where the owner's home is, and everything

121 ;; it could do with the answer would be denied anyway.

122 (let ((g (make-grants))

123 (dir (make-temp-directory)))

124 (grant-add! g (string-append "fs:rw:" dir))

125 (assert-true (guard (e (#t #t)) (fs-home g) #f))))

126

127 (test "read-dir returns stat dicts"

128 (let ((g (make-grants))

129 (dir (make-temp-directory)))

130 (grant-add! g (string-append "fs:rw:" dir))

131 (fs-write-file g (path-join dir "a.txt") "a")

132 (fs-write-file g (path-join dir "b.txt") "bb")

133 (let ((entries (fs-read-dir g dir)))

134 (assert-equal (length entries) 2)

135 (assert-true (dict-contains? (car entries) name:))

136 (assert-true (dict-contains? (car entries) size:)))))

137

138 ;; ---- canonical listing order --------------------------------------------

139 ;; Sorted at the source so every consumer agrees and no client re-sorts per

140 ;; render. `directory-list` order is the filesystem's (arbitrary), so these

141 ;; assert the ORDER itself, not merely the membership.

142

143 (define (entry-names entries) (map (lambda (e) (dict-ref e name: "")) entries))

144

145 (test "read-dir sorts: dirs before files, hidden before visible in each"

146 ;; David's four tiers: hidden dirs, dirs, hidden files, files. A repo should

147 ;; read .git/ -> src/ -> .gitignore -> README.md.

148 (let ((g (make-grants))

149 (dir (make-temp-directory)))

150 (grant-add! g (string-append "fs:rw:" dir))

151 ;; created in deliberately scrambled order

152 (fs-write-file g (path-join dir "README.md") "r")

153 (fs-mkdir g (path-join dir "src"))

154 (fs-write-file g (path-join dir ".gitignore") "i")

155 (fs-mkdir g (path-join dir ".git"))

156 (assert-equal (entry-names (fs-read-dir g dir))

157 (list ".git" "src" ".gitignore" "README.md"))))

158

159 (test "read-dir sorts alphabetically WITHIN a tier, case-insensitively"

160 ;; A file list is read by a human: ASCII order would file Zebra before apple.

161 (let ((g (make-grants))

162 (dir (make-temp-directory)))

163 (grant-add! g (string-append "fs:rw:" dir))

164 (fs-write-file g (path-join dir "Zebra.txt") "z")

165 (fs-write-file g (path-join dir "apple.txt") "a")

166 (fs-write-file g (path-join dir "Mango.txt") "m")

167 (assert-equal (entry-names (fs-read-dir g dir))

168 (list "apple.txt" "Mango.txt" "Zebra.txt"))))

169

170 (test "read-dir order is total: names differing only in case are stable"

171 (let ((g (make-grants))

172 (dir (make-temp-directory)))

173 (grant-add! g (string-append "fs:rw:" dir))

174 (fs-write-file g (path-join dir "b.txt") "b")

175 (fs-write-file g (path-join dir "B.txt") "B")

176 ;; equal case-insensitively -> the case-sensitive name breaks the tie, so the

177 ;; order is deterministic rather than filesystem-dependent

178 (assert-equal (entry-names (fs-read-dir g dir))

179 (list "B.txt" "b.txt"))))

180

181 (test "read-dir puts every directory ahead of every file"

182 (let ((g (make-grants))

183 (dir (make-temp-directory)))

184 (grant-add! g (string-append "fs:rw:" dir))

185 (fs-write-file g (path-join dir "aaa.txt") "a") ; sorts first alphabetically

186 (fs-mkdir g (path-join dir "zzz")) ; but a dir outranks it

187 (assert-equal (entry-names (fs-read-dir g dir))

188 (list "zzz" "aaa.txt"))))

189

190 (test "stat reports type and size"

191 (let ((g (make-grants))

192 (dir (make-temp-directory)))

193 (grant-add! g (string-append "fs:rw:" dir))

194 (let ((path (path-join dir "sized.txt")))

195 (fs-write-file g path "12345")

196 (let ((st (fs-stat g path)))

197 (assert-equal (dict-ref st size:) 5)

198 (assert-equal (dict-ref st type:) 'regular)))))

199

200 (test "read denied without grant"

201 (let ((g (make-grants))

202 (dir (make-temp-directory)))

203 ;; No grant added.

204 (assert-error (fs-read-dir g dir))))

205

206 (test "write denied under ro grant"

207 (let ((g (make-grants))

208 (dir (make-temp-directory)))

209 (grant-add! g (string-append "fs:ro:" dir))

210 (assert-error (fs-write-file g (path-join dir "x") "nope")))))

211

212;; ============================================================

213;; One-shot exec

214;; ============================================================

215

216(test-group "process-exec"

217

218 (test "captures stdout and exit code"

219 (let ((g (make-grants)))

220 (grant-add! g "exec:allowlist:echo")

221 (let ((r (process-exec g '("echo" "hello world"))))

222 (assert-equal (dict-ref r exit:) 0)

223 (assert-true (string-contains? (dict-ref r stdout:) "hello world")))))

224

225 (test "denied without grant"

226 (let ((g (make-grants)))

227 (assert-error (process-exec g '("echo" "no")))))

228

229 (test "cwd: runs the child in that directory"

230 ;; REGRESSION, t-b07e5f. `with-current-directory` is a PROCEDURE

231 ;; taking (path thunk), and this call site passed the spawn's RESULT

232 ;; where the thunk belonged — so `cwd:` raised

233 ;; "expected thunk to satisfy procedure?" AFTER already starting a

234 ;; child, in the caller's directory, that nothing reaped.

235 ;;

236 ;; THE ASSERTION IS ON THE DIRECTORY, NOT ON THE ABSENCE OF A RAISE.

237 ;; A version that silently ignored `cwd:` would also stop raising,

238 ;; and that is the original defect wearing a quieter coat.

239 (let ((g (make-grants))

240 (dir (make-temp-directory)))

241 (grant-add! g "exec:allowlist:pwd")

242 (grant-add! g (string-append "fs:rw:" dir))

243 (let ((r (process-exec g '("pwd") cwd: dir)))

244 (assert-equal (dict-ref r exit:) 0)

245 (assert-true (string-contains? (dict-ref r stdout:) dir)))))

246

247 (test "cwd: does not leak the process-global directory to the caller"

248 ;; The fix scopes a process-global mutation. A leak of that mutation

249 ;; would be a new bug standing where the old one was.

250 (let ((g (make-grants))

251 (dir (make-temp-directory))

252 (before (current-directory)))

253 (grant-add! g "exec:allowlist:pwd")

254 (grant-add! g (string-append "fs:rw:" dir))

255 (process-exec g '("pwd") cwd: dir)

256 (assert-equal (current-directory) before)))

257

258 (test "non-zero exit surfaces"

259 (let ((g (make-grants)))

260 (grant-add! g "exec:allowlist:false")

261 (let ((r (process-exec g '("false"))))

262 (assert-true (> (dict-ref r exit:) 0)))))

263

264 (test "stderr-heavy command does not deadlock (concurrent drain)"

265 ;; ~256 KiB to stderr while also writing stdout: with a sequential

266 ;; drain-stdout-then-stderr this deadlocks on the stderr pipe buffer.

267 ;; The concurrent drain must complete. Runs outside with-async, so it

268 ;; exercises the internal-scheduler path.

269 (let ((g (make-grants)))

270 (grant-add! g "exec:allowlist:sh")

271 (let ((r (process-exec

272 g

273 '("sh" "-c"

274 "yes 0123456789 | head -n 20000 1>&2; echo done"))))

275 (assert-equal (dict-ref r exit:) 0)

276 (assert-true (string-contains? (dict-ref r stdout:) "done"))

277 (assert-true (> (string-length (dict-ref r stderr:)) 100000))))))

278

279;; ============================================================

280;; PTY session plane — the S0 exit criterion

281;; ============================================================

282

283(test-group "pty session"

284

285 (test "open, stream ls, reap"

286 (let ((g (make-grants)))

287 (grant-add! g "pty:on")

288 (grant-add! g "exec:allowlist:ls")

289 (with-async

290 (let ((s (session-open g (dict kind: 'pty

291 argv: '("ls" "/")

292 cols: 80 rows: 24)))

293 (acc '())

294 (exit-code #f))

295 (assert-true (session? s))

296 (assert-equal (session-kind s) 'pty)

297 (for-channel (ev (session-events s))

298 (case (dict-ref ev type:)

299 ((data)

300 (set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))

301 (session-credit s (bytevector-length (dict-ref ev bytes:))))

302 ((exit)

303 (set! exit-code (dict-ref ev code:)))))

304 (assert-equal exit-code 0)

305 ;; `ls /` output should mention a well-known root entry.

306 (let ((text (apply string-append (reverse acc))))

307 (assert-true (string-contains? text "usr")))))))

308

309 (test "resize is visible to the child"

310 (let ((g (make-grants)))

311 (grant-add! g "pty:on")

312 (grant-add! g "exec:allowlist:sh")

313 (with-async

314 (let ((s (session-open g (dict kind: 'pty

315 argv: '("sh" "-c" "sleep 0.2; stty size")

316 cols: 80 rows: 24)))

317 (acc '()))

318 (session-resize s 132 50)

319 (for-channel (ev (session-events s))

320 (when (eq? (dict-ref ev type:) 'data)

321 (set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))

322 (session-credit s (bytevector-length (dict-ref ev bytes:)))))

323 ;; stty prints "rows cols".

324 (let ((text (apply string-append (reverse acc))))

325 (assert-true (string-contains? text "50 132")))))))

326

327 (test "write to stdin round-trips through the shell"

328 (let ((g (make-grants)))

329 (grant-add! g "pty:on")

330 (grant-add! g "exec:allowlist:sh")

331 (with-async

332 (let ((s (session-open g (dict kind: 'pty

333 argv: '("sh")

334 cols: 80 rows: 24)))

335 (acc '()))

336 (go (begin

337 (sleep 0.2)

338 (session-write s "echo round-trip-ok\n")

339 (sleep 0.3)

340 (session-write s "exit\n")))

341 (for-channel (ev (session-events s))

342 (when (eq? (dict-ref ev type:) 'data)

343 (set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))

344 (session-credit s (bytevector-length (dict-ref ev bytes:)))))

345 (let ((text (apply string-append (reverse acc))))

346 (assert-true (string-contains? text "round-trip-ok")))))))

347

348 (test "session-close terminates a long-running child"

349 (let ((g (make-grants)))

350 (grant-add! g "pty:on")

351 (grant-add! g "exec:allowlist:sh")

352 (with-async

353 (let ((s (session-open g (dict kind: 'pty

354 argv: '("sh" "-c" "sleep 30")

355 cols: 80 rows: 24))))

356 ;; Drain events in the background so the pump can reach EOF.

357 (go (for-channel (ev (session-events s)) #t))

358 (sleep 0.2)

359 (let ((status (session-close s)))

360 (assert-true (not (eq? status #f)))

361 (assert-false (session-alive? s))))))))

362

363;; ============================================================

364;; Process (pipes) session plane — the P0b `'process` kind, the same

365;; Session-plane contract carried over stdin/stdout pipes instead of a

366;; pty (for `tmux -C` and other control-protocol children that hard-fail

367;; on a tty). No `pty` grant: a pipe session allocates no pty, so `exec`

368;; alone gates it, matching Resource-plane process spawning.

369;; ============================================================

370

371(test-group "process session"

372

373 (test "open, stream stdout, reap — no pty grant needed"

374 (let ((g (make-grants)))

375 (grant-add! g "exec:allowlist:sh") ; deliberately NO pty:on

376 (with-async

377 (let ((s (session-open g (dict kind: 'process

378 argv: '("sh" "-c" "echo process-out"))))

379 (acc '())

380 (exit-code #f))

381 (assert-true (session? s))

382 (assert-equal (session-kind s) 'process)

383 (for-channel (ev (session-events s))

384 (case (dict-ref ev type:)

385 ((data)

386 (set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))

387 (session-credit s (bytevector-length (dict-ref ev bytes:))))

388 ((exit)

389 (set! exit-code (dict-ref ev code:)))))

390 (assert-equal exit-code 0)

391 (let ((text (apply string-append (reverse acc))))

392 (assert-true (string-contains? text "process-out")))))))

393

394 (test "cwd and environment overrides reach the child and leave the parent unchanged"

395 (let ((g (make-grants))

396 (before (getenv "SIGIL_SESSION_ENV_TEST")))

397 (grant-add! g "exec:allowlist:sh")

398 (grant-add! g "fs:ro:/tmp")

399 (with-async

400 (let ((s (session-open

401 g

402 (dict kind: 'process

403 argv: '("sh" "-c" "printf '%s|%s' \"$PWD\" \"$SIGIL_SESSION_ENV_TEST\"")

404 cwd: "/tmp"

405 env: #{ "SIGIL_SESSION_ENV_TEST" "task-value" })))

406 (acc '()))

407 (for-channel (ev (session-events s))

408 (when (eq? (dict-ref ev type:) 'data)

409 (set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))

410 (session-credit s (bytevector-length (dict-ref ev bytes:)))))

411 (assert-equal (apply string-append (reverse acc)) "/tmp|task-value")

412 (assert-equal (getenv "SIGIL_SESSION_ENV_TEST") before)))))

413

414 (test "environment overrides reject non-string values"

415 (let ((g (make-grants)))

416 (grant-add! g "exec:allowlist:true")

417 (with-async

418 (assert-error

419 (session-open g (dict kind: 'process argv: '("true")

420 env: #{ "COUNT" 3 }))))))

421

422 (test "process sessions optionally merge stderr into captured output"

423 (let ((g (make-grants)))

424 (grant-add! g "exec:allowlist:sh")

425 (with-async

426 (let ((s (session-open g (dict kind: 'process

427 argv: '("sh" "-c" "printf ERR >&2")

428 stderr: 'merge)))

429 (acc '()))

430 (for-channel (ev (session-events s))

431 (when (eq? (dict-ref ev type:) 'data)

432 (set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))

433 (session-credit s (bytevector-length (dict-ref ev bytes:)))))

434 (assert-equal (apply string-append (reverse acc)) "ERR")))))

435

436 (test "the process kind is denied without an exec grant"

437 (let ((g (make-grants)))

438 ;; No exec grant at all: even with pty:on, exec gates the spawn.

439 (grant-add! g "pty:on")

440 (with-async

441 (assert-error

442 (session-open g (dict kind: 'process argv: '("sh" "-c" "true")))))))

443

444 (test "write to stdin round-trips through cat (bidirectional pipes)"

445 (let ((g (make-grants)))

446 (grant-add! g "exec:allowlist:cat")

447 (with-async

448 (let ((s (session-open g (dict kind: 'process argv: '("cat"))))

449 (acc '()))

450 ;; cat echoes stdin -> stdout; close stdin to end the stream.

451 (go (begin

452 (sleep 0.2)

453 (session-write s "round-trip-ok\n")

454 (sleep 0.3)

455 (session-close s)))

456 (for-channel (ev (session-events s))

457 (when (eq? (dict-ref ev type:) 'data)

458 (set! acc (cons (utf8->string (dict-ref ev bytes:)) acc))

459 (session-credit s (bytevector-length (dict-ref ev bytes:)))))

460 (let ((text (apply string-append (reverse acc))))

461 (assert-true (string-contains? text "round-trip-ok")))))))

462

463 (test "resize is a harmless no-op for a pipe session"

464 (let ((g (make-grants)))

465 (grant-add! g "exec:allowlist:cat")

466 (with-async

467 (let ((s (session-open g (dict kind: 'process argv: '("cat")))))

468 ;; No pty window exists; resize must neither error nor affect I/O.

469 (session-resize s 132 50)

470 (go (for-channel (ev (session-events s)) #t))

471 (sleep 0.1)

472 (let ((status (session-close s)))

473 (assert-true (not (eq? status #f)))

474 (assert-false (session-alive? s)))))))

475

476 (test "session-close terminates a long-running pipe child"

477 (let ((g (make-grants)))

478 (grant-add! g "exec:allowlist:sh")

479 (with-async

480 (let ((s (session-open g (dict kind: 'process

481 argv: '("sh" "-c" "sleep 30")))))

482 (go (for-channel (ev (session-events s)) #t))

483 (sleep 0.2)

484 (let ((status (session-close s)))

485 (assert-true (not (eq? status #f)))

486 (assert-false (session-alive? s))))))))