lantern-system/test/test-lantern-system.sgl

1;;; Headless test suite for the lantern-system fs + pty plugin.

2;;;

3;;; Proves the whole Lantern-side capability path with NO GTK/WebKit window:

4;;;

5;;; - fs commands over (sigil system fs): read-dir / stat / read-file /

6;;; write-file / mkdir / rename / delete, plus grant-scope enforcement.

7;;; - pty commands over (sigil system session): open a REAL shell, drive it

8;;; (write / resize / signal), stream its output as pty.data events, observe

9;;; pty.exit, and prove CREDIT-BASED BACKPRESSURE (a flooding `yes` caps at

10;;; the window until credited).

11;;; - The full bridge round-trip: JSON in -> registry (allowlist) -> handler ->

12;;; _resolve / _emit JS out, through a fake recording webview backend — the

13;;; exact path a real Lantern window drives, minus the window.

14;;;

15;;; Two harness tiers: DIRECT (call a command's handler with an args dict + a

16;;; capture ctx, so output bytes are inspectable) and BRIDGE (drive JSON through

17;;; the real (lantern bridge), asserting the JS the page would receive).

19(import (sigil core)

20 (sigil test)

21 (sigil string)

22 (sigil io)

23 (sigil fs)

24 (sigil path)

25 (sigil process) ; getenv (fs.home tests)

26 (sigil async)

27 (lantern-system base64)

28 (sigil system grant)

29 (lantern registry)

30 (lantern webview)

31 (lantern bridge)

32 (lantern serve) ; make-servable-registry / make-fs-resolver

33 (lantern-system plugin)

34 (lantern-system fs) ; fs-serve-commands

35 (lantern-system pty))

37;; ============================================================

38;; Harness helpers

39;; ============================================================

41;; Find a command's handler by name in a lantern-system-commands list.

42(define (handler-for cmds name)

43 (let loop ((cs cmds))

44 (cond ((null? cs) (error "no such command" name))

45 ((string=? (dict-ref (car cs) name: #f) name) (dict-ref (car cs) handler: #f))

46 (else (loop (cdr cs))))))

48;; A ctx that CAPTURES emitted (event . payload) pairs (newest first), so a

49;; direct handler call can be inspected without a webview. emit-bulk (the

50;; bridge's bulk lane, used by the pty data pump) is normalized to the same

51;; payload shape (bytes: carries the base64) so the collectors below see both.

52(define (capture-ctx)

53 (let ((events (make-vector 1 (list))))

54 (dict emit: (lambda (ev payload)

55 (vector-set! events 0 (cons (cons ev payload) (vector-ref events 0))))

56 emit-bulk: (lambda (ev meta b64)

57 (vector-set! events 0

58 (cons (cons ev (dict-set meta bytes: b64))

59 (vector-ref events 0))))

60 captured: events)))

62(define (ctx-events ctx) (reverse (vector-ref (dict-ref ctx captured:) 0)))

63(define (events-of ctx name)

64 (filter (lambda (e) (string=? (car e) name)) (ctx-events ctx)))

65(define (saw-event? ctx name) (pair? (events-of ctx name)))

67;; Concatenate the decoded bytes of every pty.data event into a string.

68;; (base64-decode returns a bytevector — the wire is binary; utf8->string it

69;; for text assertions.)

70(define (collected-text ctx)

71 (fold-left

72 (lambda (acc e) (string-append acc (utf8->string (base64-decode (dict-ref (cdr e) bytes:)))))

73 ""

74 (events-of ctx "pty.data")))

76(define (collected-byte-count ctx) (string-length (collected-text ctx)))

78(define (b64 s) (base64-encode s))

80;; ============================================================

81;; fs commands (direct, grant scoped to a temp dir)

82;; ============================================================

84;; A fresh temp tree + a grants table scoped to it, plus the command handlers.

85(define (fs-fixture)

86 (let* ((dir (make-temp-directory))

87 (g (make-grants)))

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

89 (write-file-string (path-join dir "a.txt") "hello A")

90 (ensure-directory (path-join dir "sub"))

91 (write-file-string (path-join (path-join dir "sub") "b.txt") "bee")

92 (dict dir: dir g: g cmds: (lantern-system-commands g))))

94(test "fs.stat returns a JSON-safe stat with a string type"

95 (let* ((fx (fs-fixture))

96 (stat (handler-for (dict-ref fx cmds:) "fs.stat")))

97 (let ((r (stat (dict path: (path-join (dict-ref fx dir:) "a.txt")) #f)))

98 (assert-equal (dict-ref r type: #f) "regular")

99 (assert-equal (dict-ref r size: #f) 7)

100 (assert-equal (dict-ref r name: #f) "a.txt")

101 (assert-true (string? (dict-ref r type: #f))))))

102

103;; ---- fs.serve-file / the lantern://local/<handle> round-trip ----

104;; The load-bearing new path: a grant-checked command registers a real file, the

105;; handle-scoped fs route then serves its bytes, and unserve revokes it. The

106;; command and the route share ONE registry, exactly as the plugin wires them.

107

108(test "fs.serve-file registers a file the fs route serves; unserve revokes it"

109 (let* ((dir (make-temp-directory))

110 (g (make-grants))

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

112 (img (path-join dir "pic.png"))

113 (__ (write-file-string img "PNGDATA"))

114 (reg (make-servable-registry))

115 (serve-cmds (fs-serve-commands g reg))

116 (serve (handler-for serve-cmds "fs.serve-file"))

117 (unserve (handler-for serve-cmds "fs.unserve-file"))

118 (resolve (make-fs-resolver reg))

119 (r (serve (dict path: img) #f))

120 (handle (dict-ref r handle: #f)))

121 (assert-true (string? handle))

122 (assert-equal (dict-ref r url: #f) (string-append "lantern://local/" handle))

123 ;; the fs route now serves the registered file (200 + real-extension mime)

124 (let ((resp (resolve (string-append "/" handle))))

125 (assert-equal (dict-ref resp status: #f) 200)

126 (assert-equal (dict-ref resp mime: #f) "image/png"))

127 ;; unserve revokes the handle -> 404 (authority does not outlive the view)

128 (unserve (dict handle: handle) #f)

129 (assert-equal (dict-ref (resolve (string-append "/" handle)) status: #f) 404)))

130

131;; Registration HONORS the grant scope (fs-stat gates it): a path outside the

132;; grant raises, so a scoped embedding cannot register a file it may not read.

133(test "fs.serve-file refuses a path outside the grant scope"

134 (let* ((dir (make-temp-directory))

135 (g (make-grants))

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

137 (reg (make-servable-registry))

138 (serve (handler-for (fs-serve-commands g reg) "fs.serve-file"))

139 (raised (guard (e (#t #t)) (serve (dict path: "/etc/hostname") #f) #f)))

140 (assert-true raised)

141 ;; and nothing got registered for a would-be handle

142 (assert-equal (servable-lookup reg "f1") #f)))

143

144;; fs.read-dir now ships the listing's TSV over the BULK lane (bulk-b64) to skip

145;; the O(n²) json-encode. Decode it back to rows — the test-side mirror of

146;; (slate providers lantern) parse-dir-tsv — so these tests assert on the same

147;; entries the folder view sees.

148(define (read-dir-rows r)

149 (let ((tsv (utf8->string (base64-decode (dict-ref r bulk-b64: "")))))

150 (if (string=? tsv "")

151 '()

152 (map (lambda (line)

153 (let ((f (string-split line "\t")))

154 (dict name: (car f) type: (cadr f) size: (or (string->number (caddr f)) 0))))

155 (string-split tsv "\n")))))

156(define (read-dir-total r) (dict-ref (dict-ref r meta: #{}) total: 0))

157;; The "⋯ +N more (listing capped)" marker row (name starts with U+22EF).

158(define (cap-marker-row? e)

159 (let ((nm (dict-ref e name: "")))

160 (and (> (string-length nm) 0) (= (char->integer (string-ref nm 0)) #x22EF))))

161

162(test "fs.read-dir lists entries with kinds"

163 (let* ((fx (fs-fixture))

164 (rd (handler-for (dict-ref fx cmds:) "fs.read-dir")))

165 (let* ((r (rd (dict path: (dict-ref fx dir:)) #f))

166 (entries (read-dir-rows r))

167 (names (map (lambda (e) (dict-ref e name: #f)) entries)))

168 (assert-true (member "a.txt" names))

169 (assert-true (member "sub" names))

170 (let ((sub (let loop ((es entries))

171 (cond ((null? es) #f)

172 ((string=? (dict-ref (car es) name: #f) "sub") (car es))

173 (else (loop (cdr es)))))))

174 (assert-equal (dict-ref sub type: #f) "directory")))))

175

176(test "fs.read-dir returns entries in sigil-system's canonical order"

177 ;; This is the ONLY path Slate's folder view and find-file actually see, and it

178 ;; does NOT go through sigil-system's fs-read-dir (which stats every name and

179 ;; overflows at /gnu/store scale) — so sorting there alone would never reach a

180 ;; user. It calls fs-sort-entries on the entries it kept instead, which is what

181 ;; keeps this order identical to fs-read-dir's without re-deriving the rule.

182 (let* ((fx (fs-fixture))

183 (dir (dict-ref fx dir:))

184 (g (dict-ref fx g:))

185 (rd (handler-for (dict-ref fx cmds:) "fs.read-dir")))

186 ;; the fixture holds a.txt + sub/; add the other two tiers, out of order

187 (write-file-string (path-join dir "README.md") "r")

188 (write-file-string (path-join dir ".gitignore") "i")

189 (ensure-directory (path-join dir ".git"))

190 (let* ((r (rd (dict path: dir) #f))

191 (names (map (lambda (e) (dict-ref e name: #f)) (read-dir-rows r))))

192 ;; hidden dirs, dirs, hidden files, files — alphabetical within each tier

193 (assert-equal names (list ".git" "sub" ".gitignore" "a.txt" "README.md")))))

194

195(test "fs.read-dir honors limit: and always reports the full total"

196 (let* ((fx (fs-fixture))

197 (rd (handler-for (dict-ref fx cmds:) "fs.read-dir")))

198 ;; the fixture dir has 2 top-level entries (a.txt + sub/)

199 (let* ((r (rd (dict path: (dict-ref fx dir:) limit: 1) #f))

200 (rows (read-dir-rows r)))

201 ;; total is the FULL count (in meta:), regardless of the cap

202 (assert-equal (read-dir-total r) 2)

203 ;; 1 real kept entry, plus a visible "capped" marker row

204 (assert-equal (length (filter (lambda (e) (not (cap-marker-row? e))) rows)) 1)

205 (assert-equal (length (filter cap-marker-row? rows)) 1))

206 ;; no limit: everything, total matches, no marker

207 (let* ((r (rd (dict path: (dict-ref fx dir:)) #f))

208 (rows (read-dir-rows r)))

209 (assert-equal (length rows) 2)

210 (assert-equal (read-dir-total r) 2)

211 (assert-equal (length (filter cap-marker-row? rows)) 0))))

212

213(test "fs.read-file returns the file bytes on the bulk lane (utf8 meta)"

214 (let* ((fx (fs-fixture))

215 (rf (handler-for (dict-ref fx cmds:) "fs.read-file")))

216 (let ((r (rf (dict path: (path-join (dict-ref fx dir:) "a.txt")) #f)))

217 (assert-equal (utf8->string (base64-decode (dict-ref r bulk-b64: #f))) "hello A")

218 (assert-equal (dict-ref (dict-ref r meta: #{}) encoding: #f) "utf8"))))

219

220(test "fs.read-file base64 round-trips the bytes on the bulk lane"

221 (let* ((fx (fs-fixture))

222 (rf (handler-for (dict-ref fx cmds:) "fs.read-file")))

223 (let ((r (rf (dict path: (path-join (dict-ref fx dir:) "a.txt") encoding: "base64") #f)))

224 (assert-equal (dict-ref (dict-ref r meta: #{}) encoding: #f) "base64")

225 (assert-equal (utf8->string (base64-decode (dict-ref r bulk-b64: #f))) "hello A"))))

226

227(test "fs.home reports the home directory"

228 ;; Lets a client expand "~" without hardcoding a host convention — for a remote

229 ;; node the home that matters is the NODE's, not the one typing. The fixture's

230 ;; grants are scoped to a temp dir, so this asserts the scoped DENIAL; the

231 ;; allowed path is covered in sigil-system, which owns the grant check.

232 (let* ((fx (fs-fixture))

233 (home-cmd (handler-for (dict-ref fx cmds:) "fs.home")))

234 (assert-true (guard (e (#t #t)) (home-cmd (dict) #f) #f))))

235

236(test "fs.home reports the home directory when granted"

237 (let* ((dir (make-temp-directory))

238 (g (make-grants))

239 (home (getenv "HOME")))

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

241 (let* ((cmds (lantern-system-commands g))

242 (home-cmd (handler-for cmds "fs.home")))

243 (assert-equal (dict-ref (home-cmd (dict) #f) path: #f)

244 (or (realpath home) home)))))

245

246(test "fs.write-file writes atomically and returns a stat"

247 (let* ((fx (fs-fixture))

248 (wf (handler-for (dict-ref fx cmds:) "fs.write-file"))

249 (path (path-join (dict-ref fx dir:) "new.txt")))

250 (let ((r (wf (dict path: path content: "written here") #f)))

251 (assert-equal (dict-ref r type: #f) "regular")

252 (assert-equal (read-file-string path) "written here"))))

253

254(test "fs.write-file handles an EMPTY content string (missing-arg sentinel)"

255 (let* ((fx (fs-fixture))

256 (wf (handler-for (dict-ref fx cmds:) "fs.write-file"))

257 (path (path-join (dict-ref fx dir:) "empty.txt")))

258 (wf (dict path: path content: "") #f)

259 (assert-equal (read-file-string path) "")))

260

261(test "fs.write-file takes bulk-lane content over content:"

262 (let* ((fx (fs-fixture))

263 (wf (handler-for (dict-ref fx cmds:) "fs.write-file"))

264 (path (path-join (dict-ref fx dir:) "bulk.txt")))

265 (wf (dict path: path bulk: "bulk body wins") #f)

266 (assert-equal (read-file-string path) "bulk body wins")))

267

268(test "fs.write-file create-dirs: creates a missing parent directory"

269 ;; The ONLY test that can prove this contract: it asserts the file exists ON

270 ;; DISK, i.e. that the host ACTED. A caller-side test can only prove what was

271 ;; sent — and one did exactly that while the feature was broken, because the

272 ;; doc comment above fs.write-file advertised `create-dirs?:` and the code read

273 ;; `create-dirs:`. The flag is optional, so a misspelled name is

274 ;; indistinguishable from an absent one: no mkdir, no error.

275 ;;

276 ;; Slate's find-file needs this — you CREATE a file by typing a path that does

277 ;; not exist, and that path can name a directory that does not exist either.

278 (let* ((fx (fs-fixture))

279 (wf (handler-for (dict-ref fx cmds:) "fs.write-file"))

280 (path (path-join (dict-ref fx dir:) "fresh/new.txt")))

281 (wf (dict path: path content: "made the parent" create-dirs: #t) #f)

282 (assert-equal (read-file-string path) "made the parent")))

283

284(test "fs.write-file create-dirs: reaches exactly ONE missing level, by design"

285 ;; Pins a real limit of the GRANT model rather than of this command. To decide

286 ;; whether a path is inside a grant, sigil-system's canonical-target needs a real

287 ;; anchor: it realpaths the path, or (for a write) realpaths the PARENT and

288 ;; re-appends the basename. Two missing levels leave nothing to realpath, so the

289 ;; write is denied before mkdir is ever reached.

290 ;;

291 ;; That is the SAFE default, not an oversight: resolving further up would mean

292 ;; re-appending an unresolved tail, and a ".." in that tail could escape the

293 ;; grant root — precisely what realpath'ing the parent prevents today. Lifting it

294 ;; needs normalization of the missing tail, i.e. a deliberate change to security

295 ;; code, not a drive-by.

296 (let* ((fx (fs-fixture))

297 (wf (handler-for (dict-ref fx cmds:) "fs.write-file"))

298 (path (path-join (dict-ref fx dir:) "deep/deeper/new.txt")))

299 (assert-true (guard (e (#t #t))

300 (wf (dict path: path content: "x" create-dirs: #t) #f)

301 #f))))

302

303(test "fs.write-file WITHOUT create-dirs: does not invent directories"

304 ;; The other half of the contract: mkdir is opt-in, so a typo'd path fails loudly

305 ;; instead of silently scattering directories across the filesystem.

306 (let* ((fx (fs-fixture))

307 (wf (handler-for (dict-ref fx cmds:) "fs.write-file"))

308 (path (path-join (dict-ref fx dir:) "absent/new.txt")))

309 (assert-true (guard (e (#t #t)) (wf (dict path: path content: "x") #f) #f))))

310

311(test "fs.mkdir / fs.rename / fs.delete take effect on disk"

312 (let* ((fx (fs-fixture))

313 (dir (dict-ref fx dir:))

314 (mkdir (handler-for (dict-ref fx cmds:) "fs.mkdir"))

315 (rename (handler-for (dict-ref fx cmds:) "fs.rename"))

316 (delete (handler-for (dict-ref fx cmds:) "fs.delete")))

317 (mkdir (dict path: (path-join dir "made")) #f)

318 (assert-true (directory? (path-join dir "made")))

319 (rename (dict from: (path-join dir "a.txt") to: (path-join dir "renamed.txt")) #f)

320 (assert-true (file-exists? (path-join dir "renamed.txt")))

321 (assert-false (file-exists? (path-join dir "a.txt")))

322 (delete (dict path: (path-join dir "renamed.txt")) #f)

323 (assert-false (file-exists? (path-join dir "renamed.txt")))))

324

325(test "fs command denies a path outside the grant"

326 (let* ((fx (fs-fixture))

327 (stat (handler-for (dict-ref fx cmds:) "fs.stat")))

328 (assert-error (stat (dict path: "/etc/hostname") #f))))

329

330;; ============================================================

331;; pty commands (direct, allow-all, under with-async)

332;; ============================================================

333

334(test "pty round-trips input to output through a real pty"

335 (with-async

336 (pty-reset!)

337 (let* ((cmds (lantern-system-commands (grant-allow-all)))

338 (open (handler-for cmds "pty.open"))

339 (write (handler-for cmds "pty.write"))

340 (close (handler-for cmds "pty.close"))

341 (ctx (capture-ctx))

342 (res (open (dict argv: (list "cat")) ctx))

343 (sid (dict-ref res session: #f)))

344 (assert-true (integer? sid))

345 (assert-equal (dict-ref res cols: #f) 80)

346 (sleep 0.3)

347 (write (dict session: sid bytes: (b64 "ping-line\n")) ctx)

348 (sleep 0.4)

349 (assert-true (string-contains? (collected-text ctx) "ping-line"))

350 (close (dict session: sid) ctx)

351 (sleep 0.4)

352 (assert-true (saw-event? ctx "pty.exit")))))

353

354(test "pty runs shell commands and streams their output"

355 (with-async

356 (pty-reset!)

357 (let* ((cmds (lantern-system-commands (grant-allow-all)))

358 (open (handler-for cmds "pty.open"))

359 (write (handler-for cmds "pty.write"))

360 (close (handler-for cmds "pty.close"))

361 (ctx (capture-ctx))

362 (res (open (dict argv: (list "sh")) ctx))

363 (sid (dict-ref res session: #f)))

364 (sleep 0.3)

365 (write (dict session: sid bytes: (b64 "echo hello-from-shell\n")) ctx)

366 (sleep 0.5)

367 (assert-true (string-contains? (collected-text ctx) "hello-from-shell"))

368 (close (dict session: sid) ctx)

369 (sleep 0.3))))

370

371(test "pty.resize delivers a new size to the child (SIGWINCH via TIOCSWINSZ)"

372 (with-async

373 (pty-reset!)

374 (let* ((cmds (lantern-system-commands (grant-allow-all)))

375 (open (handler-for cmds "pty.open"))

376 (write (handler-for cmds "pty.write"))

377 (resize (handler-for cmds "pty.resize"))

378 (close (handler-for cmds "pty.close"))

379 (ctx (capture-ctx))

380 (res (open (dict argv: (list "sh") cols: 80 rows: 24) ctx))

381 (sid (dict-ref res session: #f)))

382 (sleep 0.3)

383 (resize (dict session: sid cols: 100 rows: 40) ctx)

384 (sleep 0.2)

385 (write (dict session: sid bytes: (b64 "stty size\n")) ctx)

386 (sleep 0.5)

387 ;; `stty size` prints "rows cols".

388 (assert-true (string-contains? (collected-text ctx) "40 100"))

389 (close (dict session: sid) ctx)

390 (sleep 0.3))))

391

392(test "pty.credit backpressure: a flooding producer caps at the window"

393 (with-async

394 (pty-reset!)

395 (let* ((cmds (lantern-system-commands (grant-allow-all)))

396 (open (handler-for cmds "pty.open"))

397 (credit (handler-for cmds "pty.credit"))

398 (signal (handler-for cmds "pty.signal"))

399 (close (handler-for cmds "pty.close"))

400 (ctx (capture-ctx))

401 ;; `yes` floods forever; open with a small window and DON'T credit.

402 (res (open (dict argv: (list "yes" "flood") credit: 8192) ctx))

403 (sid (dict-ref res session: #f)))

404 (sleep 0.6)

405 (let ((n1 (collected-byte-count ctx)))

406 (assert-true (> n1 0))

407 ;; Capped, NOT unbounded — the pump parked at zero window, the kernel

408 ;; buffer filled, and `yes` is blocked on write.

409 (assert-true (< n1 200000))

410 ;; Replenish credit -> more flows.

411 (credit (dict session: sid bytes: 16384) ctx)

412 (sleep 0.4)

413 (assert-true (> (collected-byte-count ctx) n1)))

414 (close (dict session: sid) ctx)

415 (sleep 0.4))))

416

417(test "pty.signal terminates the child and delivers exit"

418 (with-async

419 (pty-reset!)

420 (let* ((cmds (lantern-system-commands (grant-allow-all)))

421 (open (handler-for cmds "pty.open"))

422 (signal (handler-for cmds "pty.signal"))

423 (ctx (capture-ctx))

424 (res (open (dict argv: (list "sh" "-c" "sleep 5; echo done")) ctx))

425 (sid (dict-ref res session: #f)))

426 (sleep 0.3)

427 (signal (dict session: sid signal: "term") ctx)

428 (sleep 0.6)

429 (assert-true (saw-event? ctx "pty.exit"))

430 (assert-false (string-contains? (collected-text ctx) "done")))))

431

432;; ============================================================

433;; The bridge round-trip (JSON -> registry -> handler -> JS)

434;; ============================================================

435

436;; A fake webview backend that records every eval-js string.

437(define *evals* (make-vector 1 (list)))

438(define (reset-evals!) (vector-set! *evals* 0 (list)))

439(define (last-eval) (let ((es (vector-ref *evals* 0))) (if (null? es) #f (car es))))

440(define (all-evals) (reverse (vector-ref *evals* 0)))

441(define (fake-backend)

442 (make-backend 'fake

443 (dict eval-js: (lambda (win js)

444 (vector-set! *evals* 0 (cons js (vector-ref *evals* 0)))))))

445(define (sys-bridge g)

446 (make-bridge (fake-backend) (dict fake-window: #t)

447 (make-registry (lantern-system-commands g)) (dict fake-app: #t)))

448

449;; Substring index search (no index-returning contains in core string ops).

450(define (find-sub s sub)

451 (let ((n (string-length s)) (m (string-length sub)))

452 (let loop ((i 0))

453 (cond ((> (+ i m) n) #f)

454 ((string=? (substring s i (+ i m)) sub) i)

455 (else (loop (+ i 1)))))))

456

457;; Pull the integer after "session": out of a resolve JS string.

458(define (extract-session-id js)

459 (let ((i (find-sub js "\"session\":")))

460 (and i

461 (let loop ((j (+ i (string-length "\"session\":"))) (acc ""))

462 (if (and (< j (string-length js)) (char-numeric? (string-ref js j)))

463 (loop (+ j 1) (string-append acc (string (string-ref js j))))

464 (string->number acc))))))

465

466(define (fs-bridge-fixture)

467 (let* ((dir (make-temp-directory))

468 (g (make-grants)))

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

470 (write-file-string (path-join dir "a.txt") "hello A")

471 (dict dir: dir g: g bridge: (sys-bridge g))))

472

473(test "bridge: fs.read-dir resolves on the bulk lane (TSV base64, no entries JSON)"

474 (reset-evals!)

475 (let* ((fx (fs-bridge-fixture))

476 (bridge (dict-ref fx bridge:)))

477 (bridge-handle bridge

478 (string-append "{\"id\":1,\"cmd\":\"fs.read-dir\",\"args\":{\"path\":\""

479 (dict-ref fx dir:) "\"}}"))

480 (let ((js (last-eval)))

481 ;; the listing crosses on the BULK lane now (base64 TSV via _resolveBulk),

482 ;; NOT as an entries JSON body — that per-entry json-encode was the O(n²) cost

483 (assert-true (string-contains? js "window.lantern._resolveBulk(1,"))

484 (assert-true (string-contains? js "\"total\":")) ; the full count rides in meta

485 (assert-false (string-contains? js "entries")))))

486

487(test "bridge: fs.read-file resolves on the bulk lane (raw base64, no JSON body)"

488 (reset-evals!)

489 (let* ((fx (fs-bridge-fixture))

490 (bridge (dict-ref fx bridge:)))

491 (bridge-handle bridge

492 (string-append "{\"id\":2,\"cmd\":\"fs.read-file\",\"args\":{\"path\":\""

493 (path-join (dict-ref fx dir:) "a.txt") "\"}}"))

494 (let ((js (last-eval)))

495 (assert-true (string-contains? js "window.lantern._resolveBulk(2,"))

496 ;; the content crosses as raw base64 ("hello A" = aGVsbG8gQQ==), never as

497 ;; a json-encoded body

498 (assert-true (string-contains? js "aGVsbG8gQQ=="))

499 (assert-true (string-contains? js "\"encoding\":\"utf8\""))

500 (assert-false (string-contains? js "hello A")))))

501

502(test "bridge: fs.write-file consumes a preceding bulk frame"

503 (reset-evals!)

504 (let* ((fx (fs-bridge-fixture))

505 (bridge (dict-ref fx bridge:))

506 (path (path-join (dict-ref fx dir:) "saved.txt")))

507 ;; the page posts the bulk frame first; the dispatcher stores it before

508 ;; handling the JSON request (simulated in the same order here)

509 (assert-true (bulk-store! bridge (string-append "bulk\n7\nsaved via bulk")))

510 (bridge-handle bridge

511 (string-append "{\"id\":7,\"cmd\":\"fs.write-file\",\"args\":{\"path\":\""

512 path "\"},\"bulk\":true}"))

513 (assert-true (string-contains? (last-eval) "window.lantern._resolve(7,"))

514 (assert-equal (read-file-string path) "saved via bulk")

515 ;; the frame is consumed — a second take finds nothing

516 (assert-false (bulk-take! bridge 7))))

517

518(test "bridge: an unregistered command rejects (allowlist)"

519 (reset-evals!)

520 (let ((bridge (sys-bridge (grant-allow-all))))

521 (bridge-handle bridge "{\"id\":3,\"cmd\":\"sys.nope\",\"args\":null}")

522 (assert-true (string-contains? (last-eval) "window.lantern._reject(3,"))

523 (assert-true (string-contains? (last-eval) "unknown-command"))))

524

525(test "bridge: pty.open resolves and streams pty.data, then closes"

526 (with-async

527 (pty-reset!)

528 (reset-evals!)

529 (let ((bridge (sys-bridge (grant-allow-all))))

530 ;; `yes` produces output with no input, so pty.data must appear.

531 (bridge-handle bridge "{\"id\":4,\"cmd\":\"pty.open\",\"args\":{\"argv\":[\"yes\",\"bridge\"],\"credit\":4096}}")

532 (let ((open-js (last-eval)))

533 (assert-true (string-contains? open-js "window.lantern._resolve(4,"))

534 (assert-true (string-contains? open-js "\"session\":"))

535 (let ((sid (extract-session-id open-js)))

536 (assert-true (integer? sid))

537 (sleep 0.5)

538 ;; Somewhere in the recorded evals is a pty.data BULK emit (the pump

539 ;; rides the bulk lane when the bridge ctx provides it).

540 (assert-true (any (lambda (js) (string-contains? js "window.lantern._emitBulk(\"pty.data\","))

541 (all-evals)))

542 ;; Close through the bridge (guard the parse so a leak can't wedge).

543 (when (integer? sid)

544 (bridge-handle bridge

545 (string-append "{\"id\":5,\"cmd\":\"pty.close\",\"args\":{\"session\":"

546 (number->string sid) "}}"))

547 (sleep 0.4)))))))