test/test-server.sgl — sigil-nrepl

1(clear-module-cache! '(sigil nrepl))

2(clear-module-cache! '(sigil nrepl client))

3

4(import (sigil test)

5 (sigil socket)

6 (sigil io)

7 (sigil math)

8 (sigil string)

9 (sigil nrepl))

10

11(add-library-path! "test/fixtures/lib")

12

13(define *test-port* 57889)

14

15(define (encode-test-message sexp)

16 (let* ((str (format "~s" sexp))

17 (msg-bytes (string->utf8 str))

18 (len (bytevector-length msg-bytes))

19 (prefix (make-bytevector 4)))

20 (bytevector-u8-set! prefix 0 (quotient len 16777216))

21 (bytevector-u8-set! prefix 1 (quotient (remainder len 16777216) 65536))

22 (bytevector-u8-set! prefix 2 (quotient (remainder len 65536) 256))

23 (bytevector-u8-set! prefix 3 (remainder len 256))

24 (bytevector-append prefix msg-bytes)))

25

26(define (send-request sock request)

27 (socket-write sock (encode-test-message request)))

28

29(define (send-bytes sock bytes)

30 (socket-write sock bytes))

31

32(define (read-at-least sock n acc attempts)

33 (cond

34 ((<= attempts 0) #f)

35 ((>= (bytevector-length acc) n) acc)

36 ((socket-ready? sock 20)

37 (let ((data (socket-read-bytevector sock)))

38 (if (and data (not (eof-object? data)) (> (bytevector-length data) 0))

39 (read-at-least sock n (bytevector-append acc data) attempts)

40 (read-at-least sock n acc (- attempts 1)))))

41 (else (read-at-least sock n acc (- attempts 1)))))

42

43(define (read-response sock)

44 (let ((header (read-at-least sock 4 (make-bytevector 0) 100)))

45 (if header

46 (let* ((b0 (bytevector-u8-ref header 0))

47 (b1 (bytevector-u8-ref header 1))

48 (b2 (bytevector-u8-ref header 2))

49 (b3 (bytevector-u8-ref header 3))

50 (len (+ (* b0 16777216) (* b1 65536) (* b2 256) b3))

51 (needed (+ 4 len))

52 (full (read-at-least sock needed header 100)))

53 (and full

54 (read-expr (utf8->string (bytevector-copy full 4 needed)))))

55 #f)))

56

57(define (response-ref resp key default)

58 (let loop ((rest (if (and (pair? resp) (eq? (car resp) 'response))

59 (cdr resp)

60 '())))

61 (cond

62 ((null? rest) default)

63 ((null? (cdr rest)) default)

64 ((eq? (car rest) key) (cadr rest))

65 (else (loop (cddr rest))))))

66

67(define (pump server n)

68 (when (> n 0)

69 (nrepl-process-pending server)

70 (pump server (- n 1))))

71

72;; Buffered stream reader. Streamed eval produces MULTIPLE frames that can

73;; arrive coalesced in a single TCP segment, so a reader must preserve bytes

74;; beyond the first frame. A conn wraps a socket plus a leftover byte buffer.

75(define (make-conn sock) (vector sock (make-bytevector 0)))

76(define (conn-sock c) (vector-ref c 0))

77(define (conn-buf c) (vector-ref c 1))

78(define (conn-buf-set! c b) (vector-set! c 1 b))

79

80;; Decode one frame from a byte buffer; returns (frame . remaining) or #f.

81(define (conn-try-decode buf)

82 (if (< (bytevector-length buf) 4)

83 #f

84 (let* ((len (+ (* (bytevector-u8-ref buf 0) 16777216)

85 (* (bytevector-u8-ref buf 1) 65536)

86 (* (bytevector-u8-ref buf 2) 256)

87 (bytevector-u8-ref buf 3)))

88 (total (+ 4 len)))

89 (if (< (bytevector-length buf) total)

90 #f

91 (cons (read-expr (utf8->string (bytevector-copy buf 4 total)))

92 (bytevector-copy buf total))))))

93

94;; Read one frame from a conn, polling the socket up to `attempts` times.

95(define (conn-read-frame c attempts)

96 (let loop ((att attempts))

97 (let ((dec (conn-try-decode (conn-buf c))))

98 (if dec

99 (begin (conn-buf-set! c (cdr dec)) (car dec))

100 (if (<= att 0)

101 #f

102 (begin

103 (when (socket-ready? (conn-sock c) 20)

104 (let ((d (socket-read-bytevector (conn-sock c))))

105 (when (and d (not (eof-object? d)) (> (bytevector-length d) 0))

106 (conn-buf-set! c (bytevector-append (conn-buf c) d)))))

107 (loop (- att 1))))))))

108

109;; Read framed responses from a conn until one carries a terminal status

110;; (ok/error/exit) or max frames are read. Returns the frames in wire order.

111;; Used to observe streamed :out/:err frames that precede the final response.

112(define (conn-read-until-final c max)

113 (let loop ((i 0) (acc '()))

114 (if (>= i max)

115 (reverse acc)

116 (let ((resp (conn-read-frame c 60)))

117 (if resp

118 (let ((acc2 (cons resp acc)))

119 (if (memq (response-ref resp ':status #f) '(ok error exit))

120 (reverse acc2)

121 (loop (+ i 1) acc2)))

122 (reverse acc))))))

123

124(define (frames-with-status frames status)

125 (cond

126 ((null? frames) '())

127 ((eq? (response-ref (car frames) ':status #f) status)

128 (cons (car frames) (frames-with-status (cdr frames) status)))

129 (else (frames-with-status (cdr frames) status))))

130

131(define (any-chunk-contains? frames key needle)

132 (cond

133 ((null? frames) #f)

134 ((let ((v (response-ref (car frames) key #f)))

135 (and (string? v) (string-contains? v needle))) #t)

136 (else (any-chunk-contains? (cdr frames) key needle))))

137

138(define (request-response server sock request)

139 (send-request sock request)

140 (pump server 20)

141 (read-response sock))

142

143(define (list-contains? items value)

144 (cond

145 ((null? items) #f)

146 ((equal? (car items) value) #t)

147 (else (list-contains? (cdr items) value))))

148

149(define (with-server thunk)

150 (let ((server (nrepl-start *test-port*)))

151 (dynamic-wind

152 (lambda () #t)

153 (lambda () (thunk server))

154 (lambda () (nrepl-stop server)))))

155

156(test-group "nrepl error policy"

157 (test "default eval errors are structured and leave the session in normal mode"

158 (with-server

159 (lambda (server)

160 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

161 (pump server 5)

162 (let ((err-resp (request-response server sock

163 '(request :id "default-error" :op eval :code "(car '())"))))

164 (assert-eq (response-ref err-resp ':status #f) 'error)

165 (assert-equal (response-ref err-resp ':code #f) "eval-error")

166 (assert-false (response-ref err-resp ':in-debugger #t))

167 (assert-true (response-ref err-resp ':error #f))

168 (assert-true (string? (response-ref err-resp ':stack #f))))

169 (let ((state-resp (request-response server sock

170 '(request :id "state" :op debug-state))))

171 (assert-eq (response-ref state-resp ':status #f) 'ok)

172 (assert-false (response-ref state-resp ':in-debugger #t)))

173 (let ((ok-resp (request-response server sock

174 '(request :id "after-error" :op eval :code "(+ 20 22)"))))

175 (assert-eq (response-ref ok-resp ':status #f) 'ok)

176 (assert-equal (response-ref ok-resp ':value #f) "42"))

177 (socket-close sock))))))

178

179(test-group "nrepl debug protocol"

180 (test "debug-on-error sessions expose debugger state, frames, restarts, and quit"

181 (with-server

182 (lambda (server)

183 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

184 (pump server 5)

185 (let ((policy-resp (request-response server sock

186 '(request :id "policy" :op debug-policy :debug-on-error #t))))

187 (assert-eq (response-ref policy-resp ':status #f) 'ok)

188 (assert-true (response-ref policy-resp ':debug-on-error #f)))

189 (let ((err-resp (request-response server sock

190 '(request :id "debug-error" :op eval :code "(car '())"))))

191 (assert-eq (response-ref err-resp ':status #f) 'error)

192 (assert-true (response-ref err-resp ':in-debugger #f))

193 (assert-true (response-ref err-resp ':debugger-ops #f)))

194 (let ((frames-resp (request-response server sock

195 '(request :id "frames" :op debug-frames))))

196 (assert-eq (response-ref frames-resp ':status #f) 'ok)

197 (assert-true (response-ref frames-resp ':in-debugger #f))

198 (assert-true (string? (response-ref frames-resp ':frames #f))))

199 (let ((restarts-resp (request-response server sock

200 '(request :id "restarts" :op debug-restarts))))

201 (assert-eq (response-ref restarts-resp ':status #f) 'ok)

202 (assert-true (response-ref restarts-resp ':restarts #f)))

203 (let ((quit-resp (request-response server sock

204 '(request :id "quit" :op debug-quit))))

205 (assert-eq (response-ref quit-resp ':status #f) 'ok)

206 (assert-false (response-ref quit-resp ':in-debugger #t)))

207 (let ((ok-resp (request-response server sock

208 '(request :id "after-quit" :op eval :code "(+ 1 2)"))))

209 (assert-eq (response-ref ok-resp ':status #f) 'ok)

210 (assert-equal (response-ref ok-resp ':value #f) "3"))

211 (socket-close sock))))))

212

213(test-group "nrepl advertised ops"

214 (test "ping and info round-trip"

215 (with-server

216 (lambda (server)

217 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

218 (pump server 5)

219 (let ((ping-resp (request-response server sock

220 '(request :id "ping" :op ping))))

221 (assert-eq (response-ref ping-resp ':status #f) 'ok)

222 (assert-true (response-ref ping-resp ':pong #f)))

223 (let ((info-resp (request-response server sock

224 '(request :id "info" :op info))))

225 (assert-eq (response-ref info-resp ':status #f) 'ok)

226 (assert-equal (response-ref info-resp ':module #f) "(sigil user)"))

227 (socket-close sock)))))

228

229 (test "complete, doc, describe, macroexpand, and modules round-trip"

230 (with-server

231 (lambda (server)

232 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

233 (pump server 5)

234 (let ((complete-resp (request-response server sock

235 '(request :id "complete" :op complete :prefix "ca"))))

236 (assert-eq (response-ref complete-resp ':status #f) 'ok)

237 (assert-true (list? (response-ref complete-resp ':completions #f))))

238 (let ((doc-resp (request-response server sock

239 '(request :id "doc" :op doc :symbol "car"))))

240 (assert-eq (response-ref doc-resp ':status #f) 'ok))

241 (let ((describe-resp (request-response server sock

242 '(request :id "describe" :op describe :symbol "car"))))

243 (assert-eq (response-ref describe-resp ':status #f) 'ok)

244 (assert-equal (response-ref describe-resp ':name #f) "car"))

245 (let ((macro-resp (request-response server sock

246 '(request :id "macro" :op macroexpand :code "(when #t 1)"))))

247 (assert-eq (response-ref macro-resp ':status #f) 'ok)

248 (assert-true (string? (response-ref macro-resp ':expansion #f))))

249 (let ((modules-resp (request-response server sock

250 '(request :id "modules" :op modules))))

251 (assert-eq (response-ref modules-resp ':status #f) 'ok)

252 (assert-equal (response-ref modules-resp ':current #f) "(sigil user)")

253 (assert-true (list? (response-ref modules-resp ':modules #f))))

254 (socket-close sock)))))

255

256 (test "abort and interrupt validate provisional target-id protocol"

257 (with-server

258 (lambda (server)

259 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

260 (pump server 5)

261 (let ((missing-resp (request-response server sock

262 '(request :id "abort-missing" :op abort))))

263 (assert-eq (response-ref missing-resp ':status #f) 'error)

264 (assert-equal (response-ref missing-resp ':code #f) "missing-target-id"))

265 (let ((not-found-resp (request-response server sock

266 '(request :id "abort-unknown" :op interrupt :target-id "nope"))))

267 (assert-eq (response-ref not-found-resp ':status #f) 'error)

268 (assert-equal (response-ref not-found-resp ':code #f) "not-found"))

269 (socket-close sock))))))

270

271(test-group "nrepl framing"

272 (test "partial message reassembly waits for a complete frame"

273 (with-server

274 (lambda (server)

275 (let* ((sock (tcp-connect "127.0.0.1" *test-port*))

276 (bytes (encode-test-message

277 '(request :id "partial" :op eval :code "(+ 2 3)")))

278 (split 7))

279 (pump server 5)

280 (send-bytes sock (bytevector-copy bytes 0 split))

281 (pump server 10)

282 (assert-false (socket-ready? sock 20))

283 (send-bytes sock (bytevector-copy bytes split))

284 (pump server 20)

285 (let ((resp (read-response sock)))

286 (assert-eq (response-ref resp ':status #f) 'ok)

287 (assert-equal (response-ref resp ':value #f) "5"))

288 (socket-close sock))))))

289

290(test-group "nrepl eval semantics"

291 (test "module context is applied per request"

292 (with-server

293 (lambda (server)

294 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

295 (pump server 5)

296 (let ((resp (request-response server sock

297 '(request :id "module-eval" :op eval :module "(sigil user)" :code "(+ 6 7)"))))

298 (assert-eq (response-ref resp ':status #f) 'ok)

299 (assert-equal (response-ref resp ':module #f) "(sigil user)")

300 (assert-equal (response-ref resp ':value #f) "13"))

301 (socket-close sock)))))

302

303 (test "redefinition takes effect at name-based call sites"

304 (with-server

305 (lambda (server)

306 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

307 (pump server 5)

308 (request-response server sock

309 '(request :id "def-1" :op eval :code "(define (nrepl-test-base) 1)"))

310 (request-response server sock

311 '(request :id "def-caller" :op eval :code "(define (nrepl-test-caller) (nrepl-test-base))"))

312 (let ((first (request-response server sock

313 '(request :id "first-call" :op eval :code "(nrepl-test-caller)"))))

314 (assert-eq (response-ref first ':status #f) 'ok)

315 (assert-equal (response-ref first ':value #f) "1"))

316 (request-response server sock

317 '(request :id "def-2" :op eval :code "(define (nrepl-test-base) 2)"))

318 (let ((second (request-response server sock

319 '(request :id "second-call" :op eval :code "(nrepl-test-caller)"))))

320 (assert-eq (response-ref second ':status #f) 'ok)

321 (assert-equal (response-ref second ':value #f) "2"))

322 (socket-close sock)))))

323

324 (test "dynamic import exposes macro and upvalue-exported closure"

325 (with-server

326 (lambda (server)

327 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

328 (pump server 5)

329 (let ((import-resp (request-response server sock

330 '(request :id "fixture-import" :op eval

331 :code "(import (sigil nrepl getcell-fixture))"))))

332 (assert-eq (response-ref import-resp ':status #f) 'ok))

333 (let ((macro-resp (request-response server sock

334 '(request :id "fixture-macro" :op eval

335 :code "(nrepl-getcell-match '(1 2 3) ((a b c) (+ a b c)) (_ 0))"))))

336 (assert-eq (response-ref macro-resp ':status #f) 'ok)

337 (assert-equal (response-ref macro-resp ':value #f) "6"))

338 (let ((closure-resp (request-response server sock

339 '(request :id "fixture-closure" :op eval

340 :code "(nrepl-getcell-add-base 5)"))))

341 (assert-eq (response-ref closure-resp ':status #f) 'ok)

342 (assert-equal (response-ref closure-resp ':value #f) "47"))

343 (socket-close sock)))))

344

345 (test "macroexpand uses request module context"

346 (with-server

347 (lambda (server)

348 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

349 (pump server 5)

350 (let ((load-resp (request-response server sock

351 '(request :id "load-fixture" :op eval

352 :code "(load-module '(sigil nrepl getcell-fixture))"))))

353 (assert-eq (response-ref load-resp ':status #f) 'ok))

354 (let ((macro-resp (request-response server sock

355 '(request :id "fixture-module-macro" :op macroexpand

356 :module "(sigil nrepl getcell-fixture)"

357 :code "(nrepl-getcell-match '(1 2 3) ((a b c) (+ a b c)) (_ 0))"))))

358 (assert-eq (response-ref macro-resp ':status #f) 'ok)

359 (assert-true (string? (response-ref macro-resp ':expansion #f)))

360 (assert-false (string-contains? (response-ref macro-resp ':expansion "")

361 "nrepl-getcell-match")))

362 (socket-close sock))))))

363

364(test-group "nrepl interrupt/abort"

365 (test "a runaway eval is interrupted from a second connection and the session survives"

366 (with-server

367 (lambda (server)

368 (let ((eval-sock (tcp-connect "127.0.0.1" *test-port*)))

369 (pump server 5)

370 ;; Start a CPU-bound eval that never returns on its own.

371 (send-request eval-sock

372 '(request :id "runaway" :op eval :code "(let loop () (loop))"))

373 ;; Drive several slices — the eval keeps yielding, never completes,

374 ;; and (critically) the host loop keeps turning.

375 (pump server 10)

376 (assert-false (socket-ready? eval-sock 20)) ; no response yet

377 ;; Interrupt it from a SECOND connection.

378 (let ((abort-sock (tcp-connect "127.0.0.1" *test-port*)))

379 (pump server 3)

380 (send-request abort-sock

381 '(request :id "do-abort" :op abort :target-id "runaway"))

382 (pump server 10)

383 (let ((abort-resp (read-response abort-sock))

384 (eval-resp (read-response eval-sock)))

385 (assert-eq (response-ref abort-resp ':status #f) 'ok)

386 (assert-equal (response-ref abort-resp ':aborted #f) "runaway")

387 ;; The interrupted eval receives a terminal interrupted error.

388 (assert-eq (response-ref eval-resp ':status #f) 'error)

389 (assert-equal (response-ref eval-resp ':code #f) "interrupted"))

390 ;; Session survives: the same connection evaluates normally after.

391 (send-request eval-sock

392 '(request :id "after-abort" :op eval :code "(+ 20 22)"))

393 (pump server 20)

394 (let ((after-resp (read-response eval-sock)))

395 (assert-eq (response-ref after-resp ':status #f) 'ok)

396 (assert-equal (response-ref after-resp ':value #f) "42"))

397 (socket-close eval-sock)

398 (socket-close abort-sock))))))

399

400 (test "aborting an unknown target reports not-found and leaves running evals alone"

401 (with-server

402 (lambda (server)

403 (let ((sock (tcp-connect "127.0.0.1" *test-port*)))

404 (pump server 5)

405 (let ((resp (request-response server sock

406 '(request :id "abort-nobody" :op abort :target-id "ghost"))))

407 (assert-eq (response-ref resp ':status #f) 'error)

408 (assert-equal (response-ref resp ':code #f) "not-found"))

409 ;; A non-string :target-id must not crash the server loop; it simply

410 ;; matches nothing and reports not-found.

411 (let ((resp (request-response server sock

412 '(request :id "abort-badtype" :op abort :target-id 42))))

413 (assert-eq (response-ref resp ':status #f) 'error)

414 (assert-equal (response-ref resp ':code #f) "not-found"))

415 ;; Server still healthy afterwards.

416 (let ((resp (request-response server sock

417 '(request :id "ping-after" :op ping))))

418 (assert-eq (response-ref resp ':status #f) 'ok))

419 (socket-close sock))))))

420

421(test-group "nrepl output streaming"

422 (test "eval output streams as incremental :out frames before the final response"

423 (with-server

424 (lambda (server)

425 (let* ((sock (tcp-connect "127.0.0.1" *test-port*))

426 (conn (make-conn sock)))

427 (pump server 5)

428 ;; Two displays separated by CPU-bound spins so they land in

429 ;; different slices — proving output is flushed incrementally, not

430 ;; batched at completion.

431 (send-request sock

432 '(request :id "stream" :op eval

433

               :code "(begin (display \"chunk-a\") (let loop ((n 0)) (if (< n 80000) (loop (+ n 1)) #t)) (display \"chunk-b\") (let loop ((n 0)) (if (< n 80000) (loop (+ n 1)) #t)) 42)"))

434 (pump server 400) ; drive the sliced eval to completion

435 (let* ((frames (conn-read-until-final conn 32))

436 (out-frames (frames-with-status frames 'out))

437 (final (car (reverse frames))))

438 ;; At least one streamed :out frame arrived...

439 (assert-true (> (length out-frames) 0))

440 ;; ...carrying the original eval request id...

441 (assert-equal (response-ref (car out-frames) ':id #f) "stream")

442 ;; ...and both displayed chunks were streamed.

443 (assert-true (any-chunk-contains? out-frames ':out "chunk-a"))

444 (assert-true (any-chunk-contains? out-frames ':out "chunk-b"))

445 ;; The terminal frame is the eval result, and it comes LAST —

446 ;; every :out frame precedes it on the wire (not batched).

447 (assert-eq (response-ref final ':status #f) 'ok)

448 (assert-equal (response-ref final ':value #f) "42"))

449 (socket-close sock)))))

450

451 (test "streamed output frames arrive while the eval is still running"

452 (with-server

453 (lambda (server)

454 (let* ((sock (tcp-connect "127.0.0.1" *test-port*))

455 (conn (make-conn sock)))

456 (pump server 5)

457 (send-request sock

458 '(request :id "early" :op eval

459 :code "(begin (display \"early-out\") (let loop ((n 0)) (if (< n 300000) (loop (+ n 1)) #t)) 99)"))

460 ;; Only a few slices: enough to emit the first display and yield,

461 ;; but NOT enough to finish the long spin.

462 (pump server 6)

463 (let ((first (conn-read-frame conn 60)))

464 ;; The first frame is a streamed :out, delivered before any final

465 ;; response exists — the eval is demonstrably still suspended.

466 (assert-eq (response-ref first ':status #f) 'out)

467 (assert-equal (response-ref first ':out #f) "early-out"))

468 ;; Now let it finish and collect the terminal result.

469 (pump server 400)

470 (let ((rest (conn-read-until-final conn 32)))

471 (assert-eq (response-ref (car (reverse rest)) ':status #f) 'ok)

472 (assert-equal (response-ref (car (reverse rest)) ':value #f) "99"))

473 (socket-close sock))))))

474

475(run-tests)