Commit09c5b1c8Recorded9 Jul 2026Repositorysigil-nrepl
WIP record abort prototype
Changed
notes/item1-abort-prototype.patch | 192 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
notes/item1-test-server-prototype.sgl | 110 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 302 insertions(+)Diff
notes/item1-abort-prototype.patchadded
@@ -0,0 +1,192 @@
+1
diff --git a/src/sigil/nrepl.sgl b/src/sigil/nrepl.sgl+2
index 4e475ec..981844f 100644+3
--- a/src/sigil/nrepl.sgl+4
+++ b/src/sigil/nrepl.sgl+5
@@ -24,6 +24,7 @@+6
(sigil inspect)+7
(sigil error)+8
(sigil diagnostic)+9
+ (sigil async)+10
(sigil repl) ; Provides: make-prompt, make-debug-prompt, format-srcloc,+11
; format-proc-name, format-backtrace-str, format-frame-str,+12
; debug-help-text, parse-debug-command, string->int,+13
@@ -76,11 +77,11 @@+14
;; DATA STRUCTURES+15
;; ============================================================+16
+17
- ;; Server state: (vector 'nrepl-server socket port sessions)+18
+ ;; Server state: (vector 'nrepl-server socket port sessions clients tasks)+19
;; sessions is an alist of (session-id . session-state)+20
+21
(define (make-nrepl-server socket port)+22
- (vector 'nrepl-server socket port '() '()))+23
+ (vector 'nrepl-server socket port '() '() '()))+24
+25
(define (nrepl-server? obj)+26
(and (vector? obj)+27
@@ -105,6 +106,28 @@+28
(define (nrepl-clients-set! server clients)+29
(vector-set! server 4 clients))+30
+31
+ (define (nrepl-tasks server)+32
+ (vector-ref server 5))+33
++34
+ (define (nrepl-tasks-set! server tasks)+35
+ (vector-set! server 5 tasks))+36
++37
+ ;; Eval task: (vector 'nrepl-eval-task client request-id thunk k response done? aborted?)+38
+ (define (make-eval-task client id thunk)+39
+ (vector 'nrepl-eval-task client id thunk #f #f #f #f))+40
++41
+ (define (eval-task-client task) (vector-ref task 1))+42
+ (define (eval-task-id task) (vector-ref task 2))+43
+ (define (eval-task-thunk task) (vector-ref task 3))+44
+ (define (eval-task-k task) (vector-ref task 4))+45
+ (define (eval-task-k-set! task k) (vector-set! task 4 k))+46
+ (define (eval-task-response task) (vector-ref task 5))+47
+ (define (eval-task-response-set! task response) (vector-set! task 5 response))+48
+ (define (eval-task-done? task) (vector-ref task 6))+49
+ (define (eval-task-done-set! task done?) (vector-set! task 6 done?))+50
+ (define (eval-task-aborted? task) (vector-ref task 7))+51
+ (define (eval-task-aborted-set! task aborted?) (vector-set! task 7 aborted?))+52
++53
;; Client connection: (vector 'nrepl-client socket buffer session-id module debug-mode? debug-error debug-trace debug-frame)+54
;; debug-mode?: #t when client is in debug mode after an error+55
;; debug-error: the error message string when in debug mode+56
@@ -233,6 +256,8 @@+57
;; Dispatch on operation+58
(case op+59
((eval) (handle-eval client id args))+60
+ ((abort interrupt) (make-error-response* client id "server-required"+61
+ "abort requests must be handled by an nREPL server"))+62
((complete) (handle-complete client id args))+63
((doc) (handle-doc client id args))+64
((describe) (handle-describe client id args))+65
@@ -394,6 +419,101 @@+66
(format "~s" value))))))))))+67
result))))))+68
+69
+ (define (make-eval-thunk client id args)+70
+ (lambda () (handle-eval client id args)))+71
++72
+ (define (enqueue-eval-task! server client id args)+73
+ (let ((task (make-eval-task client id (make-eval-thunk client id args))))+74
+ (nrepl-tasks-set! server (append (nrepl-tasks server) (list task)))+75
+ #f))+76
++77
+ (define (find-task-by-id server target-id)+78
+ (let loop ((tasks (nrepl-tasks server)))+79
+ (cond+80
+ ((null? tasks) #f)+81
+ ((string=? (eval-task-id (car tasks)) target-id) (car tasks))+82
+ (else (loop (cdr tasks))))))+83
++84
+ (define (handle-abort server client id args)+85
+ (let ((target-id (get-arg args ':target-id #f)))+86
+ (if (not target-id)+87
+ (make-error-response* client id "missing-target-id" "No :target-id provided")+88
+ (let ((task (find-task-by-id server target-id)))+89
+ (if task+90
+ (begin+91
+ (eval-task-aborted-set! task #t)+92
+ (eval-task-k-set! task #f)+93
+ (eval-task-response-set! task+94
+ (make-error-response* (eval-task-client task) (eval-task-id task)+95
+ "interrupted" "Evaluation interrupted"))+96
+ (eval-task-done-set! task #t)+97
+ (make-response* client id 'ok ':aborted target-id))+98
+ (make-error-response* client id "not-found"+99
+ (format "No running eval for request id ~a" target-id)))))))+100
++101
+ (define (nrepl-handle-request* server client request)+102
+ (if (not (and (pair? request) (eq? (car request) 'request)))+103
+ (make-error-response "unknown" "invalid-request" "Expected (request ...)")+104
+ (let* ((args (cdr request))+105
+ (id (get-arg args ':id "unknown"))+106
+ (op (get-arg args ':op #f))+107
+ (module-name (get-arg args ':module #f)))+108
+ (when (and module-name (string? module-name) (not (string=? module-name "")))+109
+ (let ((mod (find-module (read-expr module-name))))+110
+ (when mod+111
+ (client-module-set! client mod))))+112
+ (case op+113
+ ((eval) (enqueue-eval-task! server client id args))+114
+ ((abort interrupt) (handle-abort server client id args))+115
+ (else (nrepl-handle-request client request))))))+116
++117
+ (define (run-eval-task-slice! task)+118
+ (when (and (not (eval-task-done? task))+119
+ (not (eval-task-aborted? task)))+120
+ (let ((saved-module (current-module))+121
+ (result #f))+122
+ (set-current-module! (client-module (eval-task-client task)))+123
+ (set-vm-async-prompt-tag! async-prompt-tag)+124
+ (set-vm-yield-requested! #t)+125
+ (set! result+126
+ (call-with-prompt+127
+ async-prompt-tag+128
+ (lambda (k op-type arg1 arg2)+129
+ (eval-task-k-set! task k)+130
+ 'yielded)+131
+ (lambda ()+132
+ (let ((k (eval-task-k task)))+133
+ (if k+134
+ (begin+135
+ (eval-task-k-set! task #f)+136
+ (k #t))+137
+ ((eval-task-thunk task)))))))+138
+ (set-vm-yield-requested! #f)+139
+ (set-current-module! saved-module)+140
+ (when (not (eq? result 'yielded))+141
+ (eval-task-response-set! task result)+142
+ (eval-task-done-set! task #t)))))+143
++144
+ (define (send-eval-task-response! task)+145
+ (let ((response (eval-task-response task))+146
+ (client (eval-task-client task)))+147
+ (when response+148
+ (socket-write (client-socket client)+149
+ (encode-message response)))))+150
++151
+ (define (process-eval-tasks server)+152
+ (let loop ((tasks (nrepl-tasks server))+153
+ (remaining '()))+154
+ (if (null? tasks)+155
+ (nrepl-tasks-set! server (reverse remaining))+156
+ (let ((task (car tasks)))+157
+ (run-eval-task-slice! task)+158
+ (if (eval-task-done? task)+159
+ (begin+160
+ (send-eval-task-response! task)+161
+ (loop (cdr tasks) remaining))+162
+ (loop (cdr tasks) (cons task remaining)))))))+163
++164
;; complete - return completions for a prefix+165
;; Includes both value bindings and syntax/macro bindings+166
(define (handle-complete client id args)+167
@@ -550,7 +670,9 @@+168
;; Accept new connections+169
(accept-pending-connections server)+170
;; Process data from existing clients+171
- (process-client-data server)))+172
+ (process-client-data server)+173
+ ;; Run one cooperative slice for each pending eval task.+174
+ (process-eval-tasks server)))+175
+176
;; Accept any pending connections+177
(define (accept-pending-connections server)+178
@@ -608,10 +730,11 @@+179
(remaining (cdr result)))+180
(client-buffer-set! client remaining)+181
;; Handle the request+182
- (let ((response (nrepl-handle-request client message)))+183
+ (let ((response (nrepl-handle-request* server client message)))+184
;; Send response+185
- (socket-write (client-socket client)+186
- (encode-message response)))+187
+ (when response+188
+ (socket-write (client-socket client)+189
+ (encode-message response))))+190
;; Check for more messages+191
(process-client-messages server client)))))+192
notes/item1-test-server-prototype.sgladded
@@ -0,0 +1,110 @@
+1
(import (sigil test)+2
(sigil socket)+3
(sigil io)+4
(sigil math)+5
(sigil string)+6
(sigil nrepl))+7
+8
(define *test-port* 57888)+9
+10
(define (encode-test-message sexp)+11
(let* ((str (format "~s" sexp))+12
(msg-bytes (string->utf8 str))+13
(len (bytevector-length msg-bytes))+14
(prefix (make-bytevector 4)))+15
(bytevector-u8-set! prefix 0 (quotient len 16777216))+16
(bytevector-u8-set! prefix 1 (quotient (remainder len 16777216) 65536))+17
(bytevector-u8-set! prefix 2 (quotient (remainder len 65536) 256))+18
(bytevector-u8-set! prefix 3 (remainder len 256))+19
(bytevector-append prefix msg-bytes)))+20
+21
(define (send-request sock request)+22
(socket-write sock (encode-test-message request)))+23
+24
(define (read-at-least sock n acc attempts)+25
(cond+26
((<= attempts 0) #f)+27
((>= (bytevector-length acc) n) acc)+28
((socket-ready? sock 20)+29
(let ((data (socket-read-bytevector sock)))+30
(if (and data (not (eof-object? data)) (> (bytevector-length data) 0))+31
(read-at-least sock n (bytevector-append acc data) attempts)+32
(read-at-least sock n acc (- attempts 1)))))+33
(else (read-at-least sock n acc (- attempts 1)))))+34
+35
(define (read-response sock)+36
(let ((header (read-at-least sock 4 (make-bytevector 0) 100)))+37
(if header+38
(let* ((b0 (bytevector-u8-ref header 0))+39
(b1 (bytevector-u8-ref header 1))+40
(b2 (bytevector-u8-ref header 2))+41
(b3 (bytevector-u8-ref header 3))+42
(len (+ (* b0 16777216) (* b1 65536) (* b2 256) b3))+43
(needed (+ 4 len))+44
(full (read-at-least sock needed header 100)))+45
(and full+46
(read-expr (utf8->string (bytevector-copy full 4 needed)))))+47
#f)))+48
+49
(define (response-ref resp key default)+50
(let loop ((rest (if (and (pair? resp) (eq? (car resp) 'response))+51
(cdr resp)+52
'())))+53
(cond+54
((null? rest) default)+55
((null? (cdr rest)) default)+56
((eq? (car rest) key) (cadr rest))+57
(else (loop (cddr rest))))))+58
+59
(define (pump server n)+60
(when (> n 0)+61
(nrepl-process-pending server)+62
(pump server (- n 1))))+63
+64
(define (with-server thunk)+65
(let ((server (nrepl-start *test-port*)))+66
(dynamic-wind+67
(lambda () #t)+68
(lambda () (thunk server))+69
(lambda () (nrepl-stop server)))))+70
+71
(test-group "nrepl server eval"+72
(test "eval round-trips through a loopback server"+73
(with-server+74
(lambda (server)+75
(let ((sock (tcp-connect "127.0.0.1" *test-port*)))+76
(send-request sock '(request :id "eval-ok" :op eval :code "(+ 1 2)"))+77
(pump server 20)+78
(let ((resp (read-response sock)))+79
(assert-eq (response-ref resp ':status #f) 'ok)+80
(assert-equal (response-ref resp ':value #f) "3"))+81
(socket-close sock))))))+82
+83
(test-group "nrepl abort"+84
(test "runaway eval can be aborted from a second connection and the session survives"+85
(with-server+86
(lambda (server)+87
(let ((eval-sock (tcp-connect "127.0.0.1" *test-port*))+88
(abort-sock #f))+89
(send-request eval-sock+90
'(request :id "runaway" :op eval :code "(let loop () (loop))"))+91
(pump server 5)+92
(set! abort-sock (tcp-connect "127.0.0.1" *test-port*))+93
(send-request abort-sock+94
'(request :id "abort-runaway" :op abort :target-id "runaway"))+95
(pump server 20)+96
(let ((abort-resp (read-response abort-sock))+97
(eval-resp (read-response eval-sock)))+98
(assert-eq (response-ref abort-resp ':status #f) 'ok)+99
(assert-eq (response-ref eval-resp ':status #f) 'error)+100
(assert-equal (response-ref eval-resp ':code #f) "interrupted"))+101
(send-request eval-sock+102
'(request :id "after-abort" :op eval :code "(+ 20 22)"))+103
(pump server 20)+104
(let ((after-resp (read-response eval-sock)))+105
(assert-eq (response-ref after-resp ':status #f) 'ok)+106
(assert-equal (response-ref after-resp ':value #f) "42"))+107
(socket-close eval-sock)+108
(socket-close abort-sock))))))+109
+110
(run-tests)