server: http-server-stop signals the serve loop through a shared stop box

Message

The server record is immutable: http-server-start and the serve loop derive updated copies, so a caller holding the record it passed to http-server-start never shares state with the loop's current record — a running-flag flip on one copy was invisible to the others, and stopping from another task silently did nothing. The loop kept serving forever (and, now that its waits suspend on the scheduler, would have kept a periodic wait alive indefinitely).

The stop signal now lives in a one-slot vector created per make-http-server and carried BY REFERENCE through every derived record. http-server-stop sets it (and still closes any sockets reachable from the record it was called on — the embedded/tick mode); the serve loop, whose waits are now all deadline-bounded (the idle listen wait was previously unbounded), sees the signal within the sweep interval, closes the sockets it owns, and http-server-start returns.

Probe phase 3 (run-starvation-test.sh) covers the goroutine-mode stop: idle server, http-server-stop from a sibling task holding the pre-start record — stop completes in ~100ms (hung forever before, watchdog-proven red on the prior server-loop). Suites: 144/144 + streaming integration all-pass; starvation phases unaffected (control 0ms / starved 1ms).

Changed

 CHANGELOG.md                               |  14 ++++++++++++++
 src/sigil/http/server.sgl                  | 129 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------------------
 test/integration/starvation-probe-main.sgl | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------------------------
 3 files changed, 186 insertions(+), 79 deletions(-)

Diff

CHANGELOG.mdmodified

@@ -9,6 +9,20 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0

### Fixed

+12

- **`http-server-stop` now actually stops a running serve loop.** The server

+13

record is immutable — `http-server-start` and the serve loop derive updated

+14

copies — so a caller that held the record it passed to `http-server-start`

+15

never shared state with the loop, and stopping from another task silently

+16

did nothing (the loop kept running forever; with the loop now suspending on

+17

the scheduler, it would have kept a periodic wait alive indefinitely). The

+18

stop signal now lives in a one-slot vector created per `make-http-server`

+19

and carried by reference through every derived record; `http-server-stop`

+20

sets it and the loop — whose waits are all deadline-bounded — sees it

+21

within the sweep interval, closes the sockets it owns, and

+22

`http-server-start` returns. Stopping an idle server completes in ~100ms

+23

(probe-verified; hung forever before). Covered by phase 3 of

+24

`test/integration/run-starvation-test.sh`.

+25

- **Server loop no longer starves other async tasks' socket I/O.** While at

least one client was connected (e.g. a browser holding an SSE stream), the

server loop's drain phase busy-spun a short-timeout native `socket-select`.

src/sigil/http/server.sglmodified

@@ -66,7 +66,22 @@

(gzip default: #f) ; Opt-in automatic gzip (Accept-Encoding)

(socket default: #f) ; Listening socket

(running default: #f) ; Running state

−69

(clients default: '())) ; Active client connections

+69

(clients default: '()) ; Active client connections

+70

(stop-box default: #f)) ; Shared 1-slot stop signal (see below)

+71

+72

;;; The server record is immutable: http-server-start and the serve loop

+73

;;; derive updated COPIES, so a caller that holds the record it passed to

+74

;;; http-server-start never shares state with the loop's current record —

+75

;;; a `running` field flip on one copy is invisible to the others. The

+76

;;; stop signal therefore lives in a one-slot vector created once per

+77

;;; make-http-server and carried BY REFERENCE through every derived copy:

+78

;;; http-server-stop sets it, and the loop (which wakes at least every

+79

;;; drain-sweep-interval-ms now that its waits are deadline-bounded)

+80

;;; checks it and shuts down. #f (no box) keeps records constructed

+81

;;; directly usable — stop then only affects the record it was called on.

+82

(define (server-stop-requested? server)

+83

(let ((box (http-server-stop-box server)))

+84

(and box (vector-ref box 0))))

;;; Client connection state

(define-struct http-client

@@ -117,7 +132,8 @@

132

backlog: backlog

133

timeout: timeout

134

max-request-size: max-request-size

−120

gzip: gzip))

+135

gzip: gzip

+136

stop-box: (vector #f)))

137

138

;;; Check if server is currently running.

139

;;;

@@ -202,17 +218,27 @@

218

219

;;; Stop the server gracefully.

220

;;;

−205

;;; Closes the listening socket and all active client connections.

+221

;;; Signals the serve loop through the shared stop box — the loop wakes

+222

;;; within drain-sweep-interval-ms, closes the sockets IT owns, and

+223

;;; http-server-start returns. This works from a sibling task holding

+224

;;; ANY record derived from the same make-http-server (including the

+225

;;; pre-start one), which is the goroutine-mode stop path. Sockets

+226

;;; reachable from THIS record are also closed directly (the

+227

;;; embedded/tick mode, where the caller drives the loop and holds the

+228

;;; current record).

229

(define (http-server-stop server)

230

(: http-server? -> http-server?)

+231

(when (http-server-stop-box server)

+232

(vector-set! (http-server-stop-box server) 0 #t))

233

;; Close listening socket first to stop accepting new connections

−209

(when (http-server-socket server)

−210

(socket-close (http-server-socket server)))

+234

(let ((sock (http-server-socket server)))

+235

(when (and sock (not (socket-closed? sock)))

+236

(socket-close sock)))

237

;; Close all active client connections

238

(for-each

239

(lambda (client)

240

(let ((sock (http-client-socket client)))

−215

(when sock

+241

(when (and sock (not (socket-closed? sock)))

242

(socket-close sock))))

243

(http-server-clients server))

244

;; Return stopped server

@@ -221,6 +247,25 @@

247

running: #f

248

clients: '()))

249

+250

;;; Close the sockets the serve loop currently owns and return the

+251

;;; stopped record. Runs inside the loop when the shared stop signal is

+252

;;; seen; tolerates sockets an embedded-mode http-server-stop already

+253

;;; closed.

+254

(define (server-loop-shutdown server)

+255

(for-each

+256

(lambda (client)

+257

(let ((sock (http-client-socket client)))

+258

(when (and sock (not (socket-closed? sock)))

+259

(socket-close sock))))

+260

(http-server-clients server))

+261

(let ((sock (http-server-socket server)))

+262

(when (and sock (not (socket-closed? sock)))

+263

(socket-close sock)))

+264

(http-server server

+265

socket: #f

+266

running: #f

+267

clients: '()))

+268

269

;;; Process one round of I/O (for custom event loops).

270

(define (http-server-tick server)

271

(: http-server? -> void?)

@@ -268,36 +313,48 @@

313

(if (not (http-server-running server))

314

server

315

(let loop ((server server))

−271

(if (not (http-server-running server))

−272

server

−273

(begin

−274

(await-readable (http-server-socket server))

−275

;; Process pending connections with guard to prevent

−276

;; a single bad connection from crashing the server loop

−277

(let ((server* (guard (exn

−278

(else

−279

(log-server-error "Exception in connection processing" exn)

−280

server))

−281

(process-connections server 0))))

−282

(let drain ((s server*))

−283

(if (null? (http-server-clients s))

−284

;; No more clients, wait for next connection

−285

(loop s)

−286

;; Clients connected — suspend until the listen

−287

;; socket or any client socket is readable (or the

−288

;; sweep deadline passes), then do one

−289

;; non-blocking processing round.

−290

(drain (guard (exn

−291

(else

−292

(log-server-error "Exception in drain loop" exn)

−293

s))

−294

(begin

−295

(await-readable-any

−296

(cons (http-server-socket s)

−297

(map http-client-socket

−298

(http-server-clients s)))

−299

timeout-ms: (drain-sweep-ms s))

−300

(process-connections s 0))))))))))))

+316

(cond

+317

((not (http-server-running server))

+318

server)

+319

;; Shared stop signal (http-server-stop from any task holding

+320

;; a record derived from the same make-http-server): close the

+321

;; sockets this loop owns and exit. Both waits below are

+322

;; deadline-bounded, so this is seen within

+323

;; drain-sweep-interval-ms of the signal.

+324

((server-stop-requested? server)

+325

(server-loop-shutdown server))

+326

(else

+327

;; Wait for a connection (bounded so a stop signal is seen

+328

;; even when the server is idle).

+329

(await-readable-any (list (http-server-socket server))

+330

timeout-ms: drain-sweep-interval-ms)

+331

;; Process pending connections with guard to prevent

+332

;; a single bad connection from crashing the server loop

+333

(let ((server* (guard (exn

+334

(else

+335

(log-server-error "Exception in connection processing" exn)

+336

server))

+337

(process-connections server 0))))

+338

(let drain ((s server*))

+339

(if (or (null? (http-server-clients s))

+340

(server-stop-requested? s))

+341

;; No more clients (or stopping) — back to the top.

+342

(loop s)

+343

;; Clients connected — suspend until the listen

+344

;; socket or any client socket is readable (or the

+345

;; sweep deadline passes), then do one

+346

;; non-blocking processing round.

+347

(drain (guard (exn

+348

(else

+349

(log-server-error "Exception in drain loop" exn)

+350

s))

+351

(begin

+352

(await-readable-any

+353

(cons (http-server-socket s)

+354

(map http-client-socket

+355

(http-server-clients s)))

+356

timeout-ms: (drain-sweep-ms s))

+357

(process-connections s 0))))))))))))

358

359

;;; Process connections using socket-select

360

(define (process-connections server timeout-ms)

test/integration/starvation-probe-main.sglmodified

@@ -21,8 +21,14 @@

;;; The harness itself only depends on timers (sleep) and native socket

;;; writes, both immune to the starvation, so it can observe it.

;;;

−24

;;; Output (one line): control-ms=N starved-ms=M (M = -1 when starved)

−25

;;; Exit: 0 when both measurements are fast, 1 when phase 2 starves.

+24

;;; phase 3 (stop): http-server-stop is called from a SIBLING task

+25

;;; (holding the pre-start record) with no traffic in

+26

;;; flight; the suspended serve loop must wake on its

+27

;;; bounded deadline, shut down, and http-server-start

+28

;;; must return promptly.

+29

;;;

+30

;;; Output (one line): control-ms=N starved-ms=M stop-ms=K (-1 = timed out)

+31

;;; Exit: 0 when all three are fast, 1 otherwise.

(define-library (starvation-probe main)

(import (sigil core)

@@ -89,47 +95,77 @@

(wait))))))))

(define (main)

−92

(with-async

−93

;; The http server under test. Long request timeout so the half-open

−94

;; client is never 408-reaped during the probe (reaping would end the

−95

;; drain spin and mask the starvation).

−96

(go (http-serve (lambda (req) (http-response/text HTTP-OK "ok"))

−97

port: http-port

−98

host: "127.0.0.1"

−99

timeout: 600000))

−100

(go

−101

;; let the server task start and park on its listen await

−102

(sleep 0.3)

+98

;; The http server under test. Long request timeout so the half-open

+99

;; client is never 408-reaped during the probe (reaping would end the

+100

;; drain spin and mask the starvation). The pre-start record is kept so

+101

;; phase 3 can stop the server from a sibling task (the goroutine-mode

+102

;; stop path).

+103

(let ((srv (make-http-server

+104

(lambda (req) (http-response/text HTTP-OK "ok"))

+105

port: http-port

+106

host: "127.0.0.1"

+107

timeout: 600000))

+108

(server-returned #f))

+109

(with-async

+110

(go

+111

(http-server-start srv)

+112

(set! server-returned #t))

+113

(go

+114

;; let the server task start and park on its listen await

+115

(sleep 0.3)

116

−104

;; phase 1 — control: no http clients, drain not running

−105

(let ((control-ms (measure-first-read-latency pair-port-base))

−106

(busy #f))

+117

;; phase 1 — control: no http clients, drain not running

+118

(let ((control-ms (measure-first-read-latency pair-port-base))

+119

(busy #f))

120

−108

;; phase 2 — park ONE half-open client on the http server:

−109

;; partial request (no terminating blank line) keeps it in

−110

;; http-server-clients, so the drain loop spins.

−111

(set! busy (%tcp-connect-sync "127.0.0.1" http-port))

−112

(socket-write busy "GET /probe HTTP/1.1\r\nHost: probe\r\n")

−113

;; give the server a chance to accept + enter the drain

−114

(sleep 0.3)

+121

;; phase 2 — park ONE half-open client on the http server:

+122

;; partial request (no terminating blank line) keeps it in

+123

;; http-server-clients, so the drain loop spins.

+124

(set! busy (%tcp-connect-sync "127.0.0.1" http-port))

+125

(socket-write busy "GET /probe HTTP/1.1\r\nHost: probe\r\n")

+126

;; give the server a chance to accept + enter the drain

+127

(sleep 0.3)

128

−116

(let ((starved-ms (measure-first-read-latency

−117

(+ pair-port-base 1))))

−118

(display (string-append

−119

"control-ms=" (number->string control-ms)

−120

" starved-ms=" (number->string starved-ms)

−121

"\n"))

−122

(when busy (socket-close busy))

−123

(cond

−124

((< control-ms 0)

−125

(display "FAIL: control measurement starved — harness broken\n")

−126

(exit 2))

−127

((< starved-ms 0)

−128

(display "STARVED: io-waiter never serviced while drain busy\n")

−129

(exit 1))

−130

((> starved-ms 2000)

−131

(display "DEGRADED: io-waiter serviced but late\n")

−132

(exit 1))

−133

(else

−134

(display "OK: io-waiter serviced promptly under load\n")

−135

(exit 0))))))))))

+129

(let ((starved-ms (measure-first-read-latency

+130

(+ pair-port-base 1))))

+131

(when busy (socket-close busy))

+132

+133

;; phase 3 — stop from a sibling task: the suspended loop

+134

;; must wake on its bounded deadline and exit promptly.

+135

(let ((t-stop (current-milliseconds)))

+136

(http-server-stop srv)

+137

(let ((stop-ms

+138

(let wait ()

+139

(cond

+140

(server-returned

+141

(- (current-milliseconds) t-stop))

+142

((> (- (current-milliseconds) t-stop)

+143

watchdog-ms)

+144

-1)

+145

(else

+146

(sleep 0.1)

+147

(wait))))))

+148

(display (string-append

+149

"control-ms=" (number->string control-ms)

+150

" starved-ms=" (number->string starved-ms)

+151

" stop-ms=" (number->string stop-ms)

+152

"\n"))

+153

(cond

+154

((< control-ms 0)

+155

(display "FAIL: control measurement starved — harness broken\n")

+156

(exit 2))

+157

((< starved-ms 0)

+158

(display "STARVED: io-waiter never serviced while drain busy\n")

+159

(exit 1))

+160

((> starved-ms 2000)

+161

(display "DEGRADED: io-waiter serviced but late\n")

+162

(exit 1))

+163

((< stop-ms 0)

+164

(display "STOP-HUNG: http-server-stop did not stop the serve loop\n")

+165

(exit 1))

+166

((> stop-ms 3000)

+167

(display "STOP-SLOW: serve loop exited but late\n")

+168

(exit 1))

+169

(else

+170

(display "OK: io-waiter serviced promptly under load; stop prompt\n")

+171

(exit 0)))))))))))))