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 "non-zero exit surfaces"

230 (let ((g (make-grants)))

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

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

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

234

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

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

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

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

239 ;; exercises the internal-scheduler path.

240 (let ((g (make-grants)))

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

242 (let ((r (process-exec

243 g

244 '("sh" "-c"

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

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

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

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

249

250;; ============================================================

251;; PTY session plane — the S0 exit criterion

252;; ============================================================

253

254(test-group "pty session"

255

256 (test "open, stream ls, reap"

257 (let ((g (make-grants)))

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

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

260 (with-async

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

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

263 cols: 80 rows: 24)))

264 (acc '())

265 (exit-code #f))

266 (assert-true (session? s))

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

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

269 (case (dict-ref ev type:)

270 ((data)

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

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

273 ((exit)

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

275 (assert-equal exit-code 0)

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

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

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

279

280 (test "resize is visible to the child"

281 (let ((g (make-grants)))

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

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

284 (with-async

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

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

287 cols: 80 rows: 24)))

288 (acc '()))

289 (session-resize s 132 50)

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

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

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

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

294 ;; stty prints "rows cols".

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

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

297

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

299 (let ((g (make-grants)))

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

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

302 (with-async

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

304 argv: '("sh")

305 cols: 80 rows: 24)))

306 (acc '()))

307 (go (begin

308 (sleep 0.2)

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

310 (sleep 0.3)

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

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

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

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

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

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

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

318

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

320 (let ((g (make-grants)))

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

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

323 (with-async

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

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

326 cols: 80 rows: 24))))

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

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

329 (sleep 0.2)

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

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

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

333

334;; ============================================================

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

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

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

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

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

340;; ============================================================

341

342(test-group "process session"

343

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

345 (let ((g (make-grants)))

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

347 (with-async

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

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

350 (acc '())

351 (exit-code #f))

352 (assert-true (session? s))

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

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

355 (case (dict-ref ev type:)

356 ((data)

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

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

359 ((exit)

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

361 (assert-equal exit-code 0)

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

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

364

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

366 (let ((g (make-grants))

367 (before (getenv "SIGIL_SESSION_ENV_TEST")))

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

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

370 (with-async

371 (let ((s (session-open

372 g

373 (dict kind: 'process

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

375 cwd: "/tmp"

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

377 (acc '()))

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

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

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

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

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

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

384

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

386 (let ((g (make-grants)))

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

388 (with-async

389 (assert-error

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

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

392

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

394 (let ((g (make-grants)))

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

396 (with-async

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

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

399 stderr: 'merge)))

400 (acc '()))

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

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

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

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

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

406

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

408 (let ((g (make-grants)))

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

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

411 (with-async

412 (assert-error

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

414

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

416 (let ((g (make-grants)))

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

418 (with-async

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

420 (acc '()))

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

422 (go (begin

423 (sleep 0.2)

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

425 (sleep 0.3)

426 (session-close s)))

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

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

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

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

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

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

433

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

435 (let ((g (make-grants)))

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

437 (with-async

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

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

440 (session-resize s 132 50)

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

442 (sleep 0.1)

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

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

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

446

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

448 (let ((g (make-grants)))

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

450 (with-async

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

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

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

454 (sleep 0.2)

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

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

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