http: add http-fetch-bytes — byte-faithful in-memory fetch for relays

Message

http-request utf8->strings the whole body (corrupting non-UTF-8 payloads: wasm, images, archives) and http-download streams to a file, so neither can back a reverse proxy that must relay arbitrary bytes with the response's status + headers intact. Add a public byte-faithful fetch:

  (http-fetch-bytes method url (keys: (headers #{}) (body #f) (timeout #f)))
    -> #{ status: <int> headers: <ordered alist> body: <bytevector> }  | #f

  * body is a BYTEVECTOR, never decoded to a string;
  * headers is an ORDERED alist of (lowercased-name . value) that preserves
    order AND duplicates (multiple Set-Cookie etc.), which a dict collapses;
  * redirects are NOT followed — a 3xx is returned untouched so the caller
    decides (a proxy must relay redirects, not chase them);
  * body assembled with a SINGLE allocation, not (apply bytevector-append
    <hundreds of chunk args>), which silently returns empty for multi-MB
    bodies. NB: read-all-data/parse-http-response behind http-request share
    that splat and so truncate large bodies — a separate follow-up, not
    touched here to keep this additive + low-risk.

Built on the module's own connection layer (connect-to-server + conn-* + find-header-end-bytes) — no internals exported. Framing: Content-Length, chunked (byte-exact dechunk), or Connection: close EOF; idle-based read deadline (resets on data) so a large steady body never times out.

Tests (test-fetch-bytes.sgl, 14): single-alloc assemble incl. a 500-chunk body (splat regression), ordered/duplicate/lowercased header alist, content-length parsing, chunked decode, unreachable -> #f. Full sigil-http suite 158 passed, no regressions.

NOTE for review: sigil.lock re-resolved to run the tests — the branch's lock pinned sigil-test to a different sigil monorepo commit than the toolchain (0.17.19 / b76109c6), a bytecode v9-vs-v10 skew that blocked the test runner. sigil deps update aligned sigil-stdlib/tls/test/crypto/git to the current toolchain + ecosystem versions (same as the slate worktree). Review/adjust during the version bump as you see fit.

Changed

 sigil.lock                |  30 +++++++++++------------
 src/sigil/http/client.sgl | 224 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 test/test-fetch-bytes.sgl | 119 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 357 insertions(+), 16 deletions(-)

Diff

sigil.lockmodified

@@ -2,10 +2,10 @@

(lock

(package name: "sigil-stdlib"

url: "codeberg:sigil/sigil"

−5

ref: "^0.17"

−6

sha: "c333fbde5ec2d805eddff982952c9993cd441715"

ref: "^0.17.10"

sha: "b76109c62d04486ecf5c4809faf89102634e97be"

package-selector: "sigil-stdlib"

−8

version: "0.17.3")

version: "0.17.19")

(package name: "sigil-socket"

url: "codeberg:sigil/sigil-socket"

ref: "^0.16.0"

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

(package name: "sigil-tls"

url: "codeberg:sigil/sigil-tls"

ref: "^0.16.0"

−17

sha: "e67c3b00b19bc495e38527203d0a563a8bcd5eab"

−18

version: "0.16.2")

+17

sha: "baf05e45ed4090406c2990debadabfcd8253d834"

+18

version: "0.16.4")

(package name: "sigil-json"

url: "codeberg:sigil/sigil-json"

ref: "^0.16.0"

@@ -24,26 +24,26 @@

(package name: "sigil-test"

url: "codeberg:sigil/sigil"

ref: "^0.17"

−27

sha: "61ba6501f4ff5d1fd534c13c4a3494b69cc88412"

+27

sha: "b76109c62d04486ecf5c4809faf89102634e97be"

package-selector: "sigil-test"

−29

version: "0.17.1")

+29

version: "0.17.19")

(package name: "sigil-test-runner"

url: "codeberg:sigil/sigil"

ref: "^0.17"

−33

sha: "61ba6501f4ff5d1fd534c13c4a3494b69cc88412"

+33

sha: "b76109c62d04486ecf5c4809faf89102634e97be"

package-selector: "sigil-test-runner"

−35

version: "0.17.1")

+35

version: "0.17.19")

(package name: "sigil-lib"

url: "codeberg:sigil/sigil"

ref: "^0.17"

−39

sha: "61ba6501f4ff5d1fd534c13c4a3494b69cc88412"

+39

sha: "b76109c62d04486ecf5c4809faf89102634e97be"

package-selector: "sigil-lib"

−41

version: "0.17.1")

+41

version: "0.17.19")

(package name: "sigil-crypto"

url: "codeberg:sigil/sigil-crypto"

ref: "^0.16"

−45

sha: "a391c4ed73891ac5dc8a6da98b80a340c03f801f"

−46

version: "0.16.3")

+45

sha: "964eec2fad375834e2b49da454209fabc059ca30"

+46

version: "0.16.4")

(package name: "sigil-ansi"

url: "codeberg:sigil/sigil-ansi"

ref: "^0.16.0"

@@ -57,6 +57,6 @@

(package name: "sigil-git"

url: "codeberg:sigil/sigil-git"

ref: "^0.16.0"

−60

sha: "0da6221050319ee241461b45eaba1a353b7bf0ec"

−61

version: "0.16.0")

+60

sha: "2d54eb99d3ca0597b3ccd9d4829d312c54721086"

+61

version: "0.16.1")

)

src/sigil/http/client.sglmodified

@@ -51,6 +51,9 @@

;; Streaming download

http-download

+54

;; Byte-faithful in-memory fetch (status + headers + raw body bytes)

+55

http-fetch-bytes

+56

;; API client helpers

build-api-url

make-response-checker

@@ -69,7 +72,12 @@

no-body-expected?

detect-framing

chunked-body-complete?

−72

framing-complete?)

+75

framing-complete?

+76

;; http-fetch-bytes internals — exported for testing

+77

fetch-parse-headers

+78

fetch-content-length

+79

fetch-assemble

+80

fetch-dechunk)

(begin

@@ -1109,6 +1117,220 @@

1117

size: bytes-written

1118

path: dest-path))))))))))

1119

+1120

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

+1121

;; Byte-faithful fetch (raw response bytes)

+1122

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

+1123

;;

+1124

;; `http-request` utf8->strings the whole body (corrupting any non-UTF-8

+1125

;; payload — wasm, images, archives), and `http-download` streams to a

+1126

;; file. `http-fetch-bytes` returns the response IN MEMORY as raw bytes so

+1127

;; a caller such as a reverse proxy can relay it byte-for-byte.

+1128

+1129

(define fetch-default-timeout 30) ; seconds

+1130

(define fetch-read-chunk 65536)

+1131

(define fetch-max-idle-polls 6000)

+1132

+1133

;;; Fetch `url` (a `method` symbol, optional request `headers` dict and

+1134

;;; string `body`) and return the response as raw bytes:

+1135

;;;

+1136

;;; #{ status: <integer>

+1137

;;; headers: <ordered alist of (lowercased-name . value)>

+1138

;;; body: <bytevector> }

+1139

;;;

+1140

;;; or #f if the upstream could not be reached / the response was

+1141

;;; unparseable. Distinct from `http-request` in three ways a byte-exact

+1142

;;; relay needs:

+1143

;;;

+1144

;;; * the body is a BYTEVECTOR, never decoded to a string;

+1145

;;; * `headers` is an ORDERED alist that preserves order AND duplicates

+1146

;;; (e.g. multiple Set-Cookie), which a dict would silently collapse;

+1147

;;; * REDIRECTS ARE NOT FOLLOWED — a 3xx is returned untouched (status +

+1148

;;; Location intact) so the caller decides whether to chase it. A

+1149

;;; reverse proxy must relay redirects, not follow them; a

+1150

;;; redirect-following wrapper can layer on top.

+1151

;;;

+1152

;;; `timeout` (seconds, or #f -> 30) bounds the TLS connect and is the

+1153

;;; IDLE read deadline (it resets whenever bytes arrive, so a large but

+1154

;;; steadily-flowing body never times out). Sends `Connection: close`, so

+1155

;;; a body with no Content-Length is read to EOF.

+1156

;;;

+1157

;;; ```

+1158

;;; (let ((r (http-fetch-bytes 'GET "https://example.com/app.wasm")))

+1159

;;; (and r (bytevector-length (dict-ref r body: #f))))

+1160

;;; ```

+1161

(define (http-fetch-bytes method url (keys: (headers #{}) (body #f) (timeout #f)))

+1162

(let ((secs (or timeout fetch-default-timeout)))

+1163

(guard (e (#t #f))

+1164

(let ((parsed (parse-url url)))

+1165

(and parsed

+1166

(let ((conn (connect-to-server parsed secs)))

+1167

(and conn

+1168

(guard (e (#t (begin (fetch-safe-close conn) #f)))

+1169

(conn-write conn (build-request-string method parsed headers body))

+1170

(let ((result (fetch-read-response conn method secs)))

+1171

(fetch-safe-close conn)

+1172

result)))))))))

+1173

+1174

(define (fetch-safe-close conn)

+1175

(guard (e (#t #f)) (conn-close conn)))

+1176

+1177

;; Phase 1: accumulate bytes until the CRLFCRLF header terminator (headers

+1178

;; are small, so the bounded append here is cheap), then hand off to the

+1179

;; body reader. Returns the result dict, or #f if the connection closed

+1180

;; before a complete header block arrived.

+1181

(define (fetch-read-response conn method timeout)

+1182

(let loop ((buf (make-bytevector 0)) (idle 0) (deadline (+ (current-second) timeout)))

+1183

(cond

+1184

((or (>= (current-second) deadline) (> idle fetch-max-idle-polls)) #f)

+1185

(else

+1186

(let ((hidx (find-header-end-bytes buf)))

+1187

(if hidx

+1188

(fetch-parse conn method timeout buf hidx)

+1189

(let ((chunk (guard (e (#t 'err)) (conn-read-bytes conn fetch-read-chunk))))

+1190

(cond

+1191

((or (eq? chunk 'err) (not chunk) (eof-object? chunk)) #f)

+1192

((zero? (bytevector-length chunk)) (loop buf (+ idle 1) deadline))

+1193

(else (loop (bytevector-append buf chunk) 0 (+ (current-second) timeout)))))))))))

+1194

+1195

;; Parse the head, then read the body per its framing. `body0` is whatever

+1196

;; body bytes already arrived with the header block.

+1197

(define (fetch-parse conn method timeout buf hidx)

+1198

(let* ((head-bytes (bytevector-copy buf 0 hidx))

+1199

(body0 (bytevector-copy buf (+ hidx 4) (bytevector-length buf)))

+1200

(lines (string-split (utf8->string head-bytes) "\r\n"))

+1201

(status (and (pair? lines)

+1202

(let ((si (parse-status-line (car lines)))) (and si (cadr si)))))

+1203

(hdrs (fetch-parse-headers (if (pair? lines) (cdr lines) '())))

+1204

(clen (fetch-content-length hdrs))

+1205

(te (fetch-header hdrs "transfer-encoding"))

+1206

(chunked? (and te (string-contains? (string-downcase te) "chunked"))))

+1207

(and status

+1208

(let ((bodyv

+1209

(cond

+1210

((no-body-expected? method status) (make-bytevector 0))

+1211

((and clen (not chunked?)) (fetch-body-clen conn timeout body0 clen))

+1212

(chunked? (fetch-dechunk (fetch-body-eof conn timeout body0)))

+1213

(else (fetch-body-eof conn timeout body0)))))

+1214

#{ status: status headers: hdrs body: bodyv }))))

+1215

+1216

;; Header lines -> ordered alist of (lowercased-name . value), preserving

+1217

;; ORDER and DUPLICATES (a relay must keep multiple Set-Cookie etc.). A

+1218

;; line with no colon is skipped.

+1219

(define (fetch-parse-headers lines)

+1220

(let loop ((ls lines) (acc '()))

+1221

(cond

+1222

((null? ls) (reverse acc))

+1223

(else

+1224

(let* ((line (car ls))

+1225

(cpos (string-index line (lambda (c) (char=? c #\:)))))

+1226

(if cpos

+1227

(let ((name (string-downcase (string-trim (substring line 0 cpos))))

+1228

(value (string-trim (substring line (+ cpos 1) (string-length line)))))

+1229

(loop (cdr ls) (cons (cons name value) acc)))

+1230

(loop (cdr ls) acc)))))))

+1231

+1232

;; First value for a (lowercased) header name, or #f.

+1233

(define (fetch-header hdrs name)

+1234

(let loop ((hs hdrs))

+1235

(cond ((null? hs) #f)

+1236

((string=? (car (car hs)) name) (cdr (car hs)))

+1237

(else (loop (cdr hs))))))

+1238

+1239

(define (fetch-content-length hdrs)

+1240

(let ((v (fetch-header hdrs "content-length")))

+1241

(and v (let ((n (string->number (string-trim v)))) (and (integer? n) (>= n 0) n)))))

+1242

+1243

;; Identity body of known Content-Length: read until `clen` bytes (or a

+1244

;; stall / EOF). Chunks accumulate in a list; assembled once. IDLE deadline

+1245

;; resets on data.

+1246

(define (fetch-body-clen conn timeout body0 clen)

+1247

(let loop ((chunks (list body0)) (have (bytevector-length body0))

+1248

(idle 0) (deadline (+ (current-second) timeout)))

+1249

(cond

+1250

((>= have clen) (fetch-assemble (reverse chunks)))

+1251

((or (>= (current-second) deadline) (> idle fetch-max-idle-polls))

+1252

(fetch-assemble (reverse chunks)))

+1253

(else

+1254

(let ((chunk (guard (e (#t 'err)) (conn-read-bytes conn fetch-read-chunk))))

+1255

(cond

+1256

((or (eq? chunk 'err) (not chunk) (eof-object? chunk)) (fetch-assemble (reverse chunks)))

+1257

((zero? (bytevector-length chunk)) (loop chunks have (+ idle 1) deadline))

+1258

(else (loop (cons chunk chunks) (+ have (bytevector-length chunk))

+1259

0 (+ (current-second) timeout)))))))))

+1260

+1261

;; Chunked or no Content-Length: read to EOF (we send Connection: close).

+1262

(define (fetch-body-eof conn timeout body0)

+1263

(let loop ((chunks (list body0)) (idle 0) (deadline (+ (current-second) timeout)))

+1264

(cond

+1265

((or (>= (current-second) deadline) (> idle fetch-max-idle-polls))

+1266

(fetch-assemble (reverse chunks)))

+1267

(else

+1268

(let ((chunk (guard (e (#t 'err)) (conn-read-bytes conn fetch-read-chunk))))

+1269

(cond

+1270

((or (eq? chunk 'err) (not chunk) (eof-object? chunk)) (fetch-assemble (reverse chunks)))

+1271

((zero? (bytevector-length chunk)) (loop chunks (+ idle 1) deadline))

+1272

(else (loop (cons chunk chunks) 0 (+ (current-second) timeout)))))))))

+1273

+1274

;; Concatenate a list of bytevectors with a SINGLE allocation. NOT

+1275

;; `(apply bytevector-append …)`: a multi-MB body arrives as hundreds of

+1276

;; chunks, and splatting that many args silently produced an EMPTY result.

+1277

(define (fetch-assemble chunks)

+1278

(let ((total (let sum ((cs chunks) (n 0))

+1279

(if (null? cs) n (sum (cdr cs) (+ n (bytevector-length (car cs))))))))

+1280

(let ((out (make-bytevector total 0)))

+1281

(let copy ((cs chunks) (pos 0))

+1282

(if (null? cs)

+1283

out

+1284

(let ((c (car cs)))

+1285

(bytevector-copy! out pos c 0 (bytevector-length c))

+1286

(copy (cdr cs) (+ pos (bytevector-length c)))))))))

+1287

+1288

;; Byte-exact chunked-transfer decode: strip the hex size lines + CRLFs.

+1289

;; Stops at the 0-size terminator or a truncated tail (best-effort).

+1290

(define (fetch-dechunk bv)

+1291

(let ((len (bytevector-length bv)))

+1292

(let loop ((pos 0) (out '()))

+1293

(if (>= pos len)

+1294

(fetch-assemble (reverse out))

+1295

(let ((line-end (fetch-find-crlf bv pos)))

+1296

(if (not line-end)

+1297

(fetch-assemble (reverse out))

+1298

(let* ((size (fetch-hex (utf8->string (bytevector-copy bv pos line-end))))

+1299

(data (+ line-end 2)))

+1300

(cond

+1301

((or (not size) (<= size 0)) (fetch-assemble (reverse out)))

+1302

((> (+ data size) len) (fetch-assemble (reverse out)))

+1303

(else (loop (+ data size 2)

+1304

(cons (bytevector-copy bv data (+ data size)) out)))))))))))

+1305

+1306

(define (fetch-find-crlf bv pos)

+1307

(let ((len (bytevector-length bv)))

+1308

(let loop ((i pos))

+1309

(cond

+1310

((> (+ i 2) len) #f)

+1311

((and (= (bytevector-u8-ref bv i) 13) (= (bytevector-u8-ref bv (+ i 1)) 10)) i)

+1312

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

+1313

+1314

(define (fetch-hex s)

+1315

(let* ((t (string-trim s))

+1316

(semi (string-index t (lambda (c) (char=? c #\;))))

+1317

(hx (if semi (substring t 0 semi) t))

+1318

(len (string-length hx)))

+1319

(if (= len 0)

+1320

#f

+1321

(let loop ((i 0) (acc 0))

+1322

(if (>= i len)

+1323

acc

+1324

(let ((d (fetch-hex-digit (string-ref hx i))))

+1325

(if d (loop (+ i 1) (+ (* acc 16) d)) #f)))))))

+1326

+1327

(define (fetch-hex-digit ch)

+1328

(cond

+1329

((and (char>=? ch #\0) (char<=? ch #\9)) (- (char->integer ch) 48))

+1330

((and (char>=? ch #\a) (char<=? ch #\f)) (+ 10 (- (char->integer ch) 97)))

+1331

((and (char>=? ch #\A) (char<=? ch #\F)) (+ 10 (- (char->integer ch) 65)))

+1332

(else #f)))

+1333

1334

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

1335

;; API Client Helpers

1336

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

test/test-fetch-bytes.sgladded

@@ -0,0 +1,119 @@

;;; Tests for (sigil http client) http-fetch-bytes — the byte-faithful fetch

;;; and its internals (assembly, header alist, chunked decode, content-length).

(import (sigil test)

(sigil core)

(sigil io)

(sigil string)

(sigil time)

(sigil socket)

+10

(sigil http client))

+11

+12

;; Content-compare two bytevectors (assert-equal on bytevectors is not

+13

;; guaranteed structural, so compare bytes explicitly).

+14

(define (bv=? a b)

+15

(and (= (bytevector-length a) (bytevector-length b))

+16

(let loop ((i 0))

+17

(cond

+18

((>= i (bytevector-length a)) #t)

+19

((= (bytevector-u8-ref a i) (bytevector-u8-ref b i)) (loop (+ i 1)))

+20

(else #f)))))

+21

+22

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

+23

;; fetch-assemble — single-allocation concat

+24

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

+25

;; The regression that motivated this: a multi-MB body arrives as hundreds of

+26

;; chunks, and `(apply bytevector-append <hundreds of args>)` silently returned

+27

;; an EMPTY bytevector. The single-allocation assemble must produce the full

+28

;; length with correct content regardless of chunk count.

+29

+30

(test-group "fetch-assemble"

+31

+32

(test "empty list -> empty bytevector"

+33

(assert-equal (bytevector-length (fetch-assemble '())) 0))

+34

+35

(test "single chunk preserved"

+36

(assert-true (bv=? (fetch-assemble (list (string->utf8 "hello")))

+37

(string->utf8 "hello"))))

+38

+39

(test "chunks concatenated in order"

+40

(assert-true (bv=? (fetch-assemble (list (string->utf8 "ab")

+41

(string->utf8 "c")

+42

(string->utf8 "def")))

+43

(string->utf8 "abcdef"))))

+44

+45

(test "hundreds of chunks assemble to full length (no splat truncation)"

+46

(let* ((chunk (make-bytevector 1024 65)) ; 1 KB of 'A'

+47

(n 500)

+48

(chunks (let build ((i 0) (acc '()))

+49

(if (>= i n) acc (build (+ i 1) (cons chunk acc)))))

+50

(out (fetch-assemble chunks)))

+51

(assert-equal (bytevector-length out) (* n 1024))

+52

(assert-equal (bytevector-u8-ref out 0) 65)

+53

(assert-equal (bytevector-u8-ref out (- (* n 1024) 1)) 65))))

+54

+55

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

+56

;; fetch-parse-headers — ordered alist, dups + order preserved, lowercased

+57

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

+58

+59

(test-group "fetch-parse-headers"

+60

+61

(test "name lowercased, value trimmed"

+62

(let ((h (fetch-parse-headers (list "Content-Type: text/html"

+63

"Content-Length: 5"))))

+64

(assert-equal (length h) 2)

+65

(assert-equal (car (car h)) "content-type")

+66

(assert-equal (cdr (car h)) "text/html")

+67

(assert-equal (cdr (cadr h)) "5")))

+68

+69

(test "duplicate headers preserved, in order"

+70

(let ((h (fetch-parse-headers (list "Set-Cookie: a=1"

+71

"Set-Cookie: b=2"))))

+72

(assert-equal (length h) 2)

+73

(assert-equal (cdr (car h)) "a=1")

+74

(assert-equal (cdr (cadr h)) "b=2")))

+75

+76

(test "line without a colon is skipped"

+77

(assert-equal (length (fetch-parse-headers (list "garbage-no-colon" "X: 1"))) 1)))

+78

+79

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

+80

;; fetch-content-length

+81

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

+82

+83

(test-group "fetch-content-length"

+84

+85

(test "present -> integer"

+86

(assert-equal (fetch-content-length (list (cons "content-length" "42"))) 42))

+87

+88

(test "absent -> #f"

+89

(assert-false (fetch-content-length (list (cons "content-type" "x")))))

+90

+91

(test "non-numeric -> #f"

+92

(assert-false (fetch-content-length (list (cons "content-length" "abc"))))))

+93

+94

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

+95

;; fetch-dechunk — byte-exact chunked-transfer decode

+96

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

+97

+98

(test-group "fetch-dechunk"

+99

+100

(test "single chunk"

+101

(assert-true (bv=? (fetch-dechunk (string->utf8 "5\r\nhello\r\n0\r\n\r\n"))

+102

(string->utf8 "hello"))))

+103

+104

(test "multiple chunks concatenated"

+105

(assert-true (bv=? (fetch-dechunk (string->utf8 "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\n"))

+106

(string->utf8 "hello world"))))

+107

+108

(test "hex chunk size"

+109

(assert-true (bv=? (fetch-dechunk (string->utf8 "a\r\n0123456789\r\n0\r\n\r\n"))

+110

(string->utf8 "0123456789")))))

+111

+112

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

+113

;; http-fetch-bytes — unreachable upstream returns #f (no server needed)

+114

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

+115

+116

(test-group "http-fetch-bytes"

+117

+118

(test "connection refused -> #f"

+119

(assert-false (http-fetch-bytes 'GET "http://127.0.0.1:9/" timeout: 2))))