Harden nREPL error policy

Changed

 src/sigil/nrepl.sgl  | 142 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------------------------------
 test/test-server.sgl | 137 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 246 insertions(+), 33 deletions(-)

Diff

src/sigil/nrepl.sglmodified

@@ -105,13 +105,14 @@

105

(define (nrepl-clients-set! server clients)

106

(vector-set! server 4 clients))

107

−108

    ;; Client connection: (vector 'nrepl-client socket buffer session-id module debug-mode? debug-error debug-trace debug-frame)

+108

    ;; Client connection: (vector 'nrepl-client socket buffer session-id module debug-mode? debug-error debug-trace debug-frame debug-on-error?)

109

;; debug-mode?: #t when client is in debug mode after an error

110

;; debug-error: the error message string when in debug mode

111

;; debug-trace: captured stack trace for the current error

112

;; debug-frame: current frame index for navigation (0 = innermost)

+113

;; debug-on-error?: opt-in policy; default wire sessions stay in normal mode

114

(define (make-nrepl-client socket session-id)

−114

(vector 'nrepl-client socket (make-bytevector 0) session-id (nrepl-get-user-module) #f #f #f 0))

+115

(vector 'nrepl-client socket (make-bytevector 0) session-id (nrepl-get-user-module) #f #f #f 0 #f))

116

117

(define (client-socket client)

118

(vector-ref client 1))

@@ -155,6 +156,12 @@

156

(define (client-debug-frame-set! client frame)

157

(vector-set! client 8 frame))

158

+159

(define (client-debug-on-error? client)

+160

(vector-ref client 9))

+161

+162

(define (client-debug-on-error-set! client enabled?)

+163

(vector-set! client 9 enabled?))

+164

165

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

166

;; WIRE PROTOCOL

167

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

@@ -239,6 +246,11 @@

246

((macroexpand) (handle-macroexpand client id args))

247

((modules) (handle-modules client id args))

248

((info) (handle-info client id args))

+249

((debug-policy) (handle-debug-policy client id args))

+250

((debug-state) (handle-debug-state client id args))

+251

((debug-frames) (handle-debug-frames client id args))

+252

((debug-restarts) (handle-debug-restarts client id args))

+253

((debug-quit) (handle-debug-quit client id args))

254

((ping) (make-response id 'ok ':pong #t))

255

(else (make-error-response id "unknown-op"

256

(format "Unknown operation: ~a" op)))))))

@@ -268,6 +280,34 @@

280

(define (make-error-response id code message)

281

(list 'response ':id id ':status 'error ':code code ':message message))

282

+283

(define (trace->wire trace)

+284

(if trace

+285

(format "~s" trace)

+286

""))

+287

+288

(define (error-message exn)

+289

(if (string? exn) exn (format "~s" exn)))

+290

+291

(define (wire-error code exn)

+292

(list ':type code

+293

':message (error-message exn)

+294

':repr (format "~s" exn)))

+295

+296

(define (make-structured-error-response* client id code exn trace)

+297

(let ((message (error-message exn)))

+298

(make-response* client id 'error

+299

':code code

+300

':message message

+301

':error (wire-error code exn)

+302

':stack (trace->wire trace)

+303

':in-debugger (client-debug-mode? client))))

+304

+305

(define (clear-debug-mode! client)

+306

(client-debug-mode-set! client #f)

+307

(client-debug-error-set! client #f)

+308

(client-debug-trace-set! client #f)

+309

(client-debug-frame-set! client 0))

+310

311

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

312

;; DEBUG COMMAND HANDLING

313

;;; Uses shared functions from (sigil repl)

@@ -292,18 +332,15 @@

332

(case (car result)

333

((quit)

334

;; Exit debug mode

−295

(client-debug-mode-set! client #f)

−296

(client-debug-error-set! client #f)

−297

(client-debug-trace-set! client #f)

−298

(client-debug-frame-set! client 0)

−299

(make-response* client id 'ok ':value "Returning to REPL"))

+335

(clear-debug-mode! client)

+336

(make-response* client id 'ok ':value "Returning to REPL" ':in-debugger #f))

337

((set-frame)

338

;; Update frame and return text

339

(client-debug-frame-set! client (cadr result))

−303

(make-response* client id 'ok ':value (caddr result)))

+340

(make-response* client id 'ok ':value (caddr result) ':in-debugger #t))

341

((output error)

342

;; Return the text

−306

(make-response* client id 'ok ':value (cadr result))))))

+343

(make-response* client id 'ok ':value (cadr result) ':in-debugger #t)))))

344

345

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

346

;; OPERATIONS

@@ -325,10 +362,23 @@

362

(client-debug-trace-set! client trace)

363

(client-debug-frame-set! client 0))

364

+365

(define (make-debug-entry-response* client id code exn trace)

+366

(let ((message (error-message exn)))

+367

(enter-debug-mode-with-trace! client message trace)

+368

(make-response* client id 'error

+369

':code code

+370

':message message

+371

':error (wire-error code exn)

+372

':stack (trace->wire trace)

+373

':in-debugger #t

+374

':debugger-ops '(debug-state debug-frames debug-restarts debug-quit)

+375

':debug-hint "Use debug-frames/debug-restarts/debug-quit protocol ops")))

+376

377

;; eval - evaluate code in session's module context

378

;; Supports REPL commands (,m, ,use, etc.) via shared command handling

379

;; Catches both Scheme exceptions (via guard) and VM errors (via vm-error-prompt-tag)

−331

;; Maintains debug mode state per-session for consistent REPL experience

+380

;; Default wire sessions return structured errors and remain in normal eval mode.

+381

;; Debug mode is entered only when the session's debug-on-error policy is enabled.

382

(define (handle-eval client id args)

383

(let ((code (get-arg args ':code ""))

384

(fmt (get-arg args ':format #f)))

@@ -347,36 +397,26 @@

397

;; Wrap in VM error prompt to catch native function errors

398

(call-with-prompt

399

(vm-error-prompt-tag)

−350

;; VM error handler - enters debug mode

+400

;; VM error handler

401

(lambda (k vm-error-message)

402

(set-current-module! saved-module)

−353

(if structured?

−354

(let ((err (exception->error vm-error-message)))

−355

(make-response* client id 'error

−356

':error (inspect-error err)))

−357

(begin

−358

(enter-debug-mode! client vm-error-message)

−359

(make-response* client id 'error

−360

':code "vm-error"

−361

':message vm-error-message

−362

':debug-hint "(type ,help for debug commands, ,q to exit)"))))

+403

(let ((trace (last-stack-trace)))

+404

(if (client-debug-on-error? client)

+405

(make-debug-entry-response* client id "vm-error" vm-error-message trace)

+406

(begin

+407

(clear-debug-mode! client)

+408

(make-structured-error-response* client id "vm-error" vm-error-message trace)))))

409

;; Body with Scheme exception handling

410

(lambda ()

411

(guard (exn

412

(else

413

(set-current-module! saved-module)

−368

(if structured?

−369

(make-response* client id 'error

−370

':error (inspect-error exn))

−371

(let* ((err-msg (if (string? exn)

−372

exn

−373

(format "~s" exn)))

−374

(trace (capture-debug-trace)))

−375

(enter-debug-mode-with-trace! client err-msg trace)

−376

(make-response* client id 'error

−377

':code "eval-error"

−378

':message err-msg

−379

':debug-hint "(type ,help for debug commands, ,q to exit)")))))

+414

(let ((trace (capture-debug-trace)))

+415

(if (client-debug-on-error? client)

+416

(make-debug-entry-response* client id "eval-error" exn trace)

+417

(begin

+418

(clear-debug-mode! client)

+419

(make-structured-error-response* client id "eval-error" exn trace))))))

420

;; Check for REPL commands (,m, ,use, etc.)

421

(if (repl-command? code)

422

(let ((cmd-result (handle-command code)))

@@ -394,6 +434,42 @@

434

(format "~s" value))))))))))

435

result))))))

436

+437

(define (handle-debug-policy client id args)

+438

(let ((enabled? (get-arg args ':debug-on-error #f)))

+439

(client-debug-on-error-set! client (and enabled? #t))

+440

(when (not enabled?)

+441

(clear-debug-mode! client))

+442

(make-response* client id 'ok

+443

':debug-on-error (client-debug-on-error? client)

+444

':in-debugger (client-debug-mode? client))))

+445

+446

(define (handle-debug-state client id args)

+447

(make-response* client id 'ok

+448

':debug-on-error (client-debug-on-error? client)

+449

':in-debugger (client-debug-mode? client)

+450

':message (client-debug-error client)

+451

':current-frame (client-debug-frame client)

+452

':has-frames (and (client-debug-trace client) #t)))

+453

+454

(define (handle-debug-frames client id args)

+455

(if (not (client-debug-mode? client))

+456

(make-error-response* client id "not-in-debugger" "Session is not in debugger")

+457

(make-response* client id 'ok

+458

':in-debugger #t

+459

':current-frame (client-debug-frame client)

+460

':frames (trace->wire (client-debug-trace client)))))

+461

+462

(define (handle-debug-restarts client id args)

+463

(if (not (client-debug-mode? client))

+464

(make-error-response* client id "not-in-debugger" "Session is not in debugger")

+465

(make-response* client id 'ok

+466

':in-debugger #t

+467

':restarts '((quit "Return to normal eval mode")))))

+468

+469

(define (handle-debug-quit client id args)

+470

(clear-debug-mode! client)

+471

(make-response* client id 'ok ':in-debugger #f ':value "Returning to REPL"))

+472

473

;; complete - return completions for a prefix

474

;; Includes both value bindings and syntax/macro bindings

475

(define (handle-complete client id args)

test/test-server.sgladded

@@ -0,0 +1,137 @@

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

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

(import (sigil test)

(sigil socket)

(sigil io)

(sigil math)

(sigil string)

(sigil nrepl))

+10

+11

(define *test-port* 57889)

+12

+13

(define (encode-test-message sexp)

+14

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

+15

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

+16

(len (bytevector-length msg-bytes))

+17

(prefix (make-bytevector 4)))

+18

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

+19

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

+20

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

+21

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

+22

(bytevector-append prefix msg-bytes)))

+23

+24

(define (send-request sock request)

+25

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

+26

+27

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

+28

(cond

+29

((<= attempts 0) #f)

+30

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

+31

((socket-ready? sock 20)

+32

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

+33

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

+34

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

+35

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

+36

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

+37

+38

(define (read-response sock)

+39

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

+40

(if header

+41

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

+42

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

+43

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

+44

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

+45

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

+46

(needed (+ 4 len))

+47

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

+48

(and full

+49

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

+50

#f)))

+51

+52

(define (response-ref resp key default)

+53

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

+54

(cdr resp)

+55

'())))

+56

(cond

+57

((null? rest) default)

+58

((null? (cdr rest)) default)

+59

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

+60

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

+61

+62

(define (pump server n)

+63

(when (> n 0)

+64

(nrepl-process-pending server)

+65

(pump server (- n 1))))

+66

+67

(define (request-response server sock request)

+68

(send-request sock request)

+69

(pump server 20)

+70

(read-response sock))

+71

+72

(define (with-server thunk)

+73

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

+74

(dynamic-wind

+75

(lambda () #t)

+76

(lambda () (thunk server))

+77

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

+78

+79

(test-group "nrepl error policy"

+80

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

+81

(with-server

+82

(lambda (server)

+83

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

+84

(pump server 5)

+85

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

+86

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

+87

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

+88

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

+89

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

+90

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

+91

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

+92

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

+93

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

+94

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

+95

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

+96

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

+97

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

+98

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

+99

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

+100

(socket-close sock))))))

+101

+102

(test-group "nrepl debug protocol"

+103

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

+104

(with-server

+105

(lambda (server)

+106

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

+107

(pump server 5)

+108

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

+109

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

+110

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

+111

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

+112

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

+113

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

+114

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

+115

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

+116

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

+117

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

+118

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

+119

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

+120

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

+121

)

+122

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

+123

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

+124

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

+125

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

+126

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

+127

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

+128

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

+129

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

+130

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

+131

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

+132

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

+133

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

+134

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

+135

(socket-close sock))))))

+136

+137

(run-tests)