AtlatestRepositorysigil-wire

sigil-wire / tree / src / sigilwire.sgl

1;;; (sigil wire) - Typed binary codec for the Sigil value model
2;;;
3;;; A length-prefixed, typed serialization of Sigil values, decoded in one
4;;; O(n) forward pass with string/bytevector bodies memcpy'd (no per-char
5;;; work). This is the transport-neutral wire format for bulk structured
6;;; payloads: the binary sibling to (sigil json).
7;;;
8;;; ## Why this exists
9;;;
10;;; JSON encoding of Sigil values is O(n^2) on the bulk path because
11;;; `string-ref` is O(index) over UTF-8 and the encoder walks per-char. This
12;;; codec keeps the "don't parse, just rehydrate" property that the base64
13;;; bulk lane already proves: a tag byte says what follows, a varint says how
14;;; long, and string/bytevector bodies are copied wholesale.
15;;;
16;;; JSON stays for tiny CONTROL messages (opens, acks, credits); this codec is
17;;; for BULK structured payloads.
18;;;
19;;; ## Wire format
20;;;
21;;; ```
22;;; message: MAGIC(2)=0x53 0x57 VERSION(1)=1 FLAGS(1)=0 <value>
23;;; value: TAG(1) <payload>
24;;; ```
25;;;
26;;; Lengths and counts are unsigned LEB128 varints (small collections stay one
27;;; byte). Value tags:
28;;;
29;;; | TAG | type | payload |
30;;; |------|------------|----------------------------------------------------|
31;;; | 0x00 | #f / nil | (none) |
32;;; | 0x01 | #t | (none) |
33;;; | 0x02 | int | zigzag LEB128 varint (bignum-safe, single format) |
34;;; | 0x03 | float | 8 bytes IEEE-754 double, little-endian |
35;;; | 0x04 | string | uvarint N, then N UTF-8 bytes (memcpy) |
36;;; | 0x05 | bytevector | uvarint N, then N raw bytes (memcpy) |
37;;; | 0x06 | keyword | uvarint N, then N UTF-8 bytes |
38;;; | 0x07 | symbol | uvarint N, then N UTF-8 bytes |
39;;; | 0x08 | char | uvarint Unicode codepoint |
40;;; | 0x09 | list | uvarint K, then K values |
41;;; | 0x0A | dict | uvarint K, then K (key value) pairs |
42;;; | 0x0B | vector | uvarint K, then K values (R7RS #(...)) |
43;;; | 0x0C | array | uvarint K, then K values (Sigil #[...]) |
44;;;
45;;; ## Basic usage
46;;;
47;;; ```scheme
48;;; (import (sigil wire))
49;;;
50;;; (define bytes (wire-encode #{ name: "Alice" scores: #[10 20 30] }))
51;;; (wire-decode bytes)
52;;; ; => #{ name: "Alice" scores: #[10 20 30] }
53;;; ```
54;;;
55;;; ## Security: the decoder is a trust boundary
56;;;
57;;; Bytes handed to `wire-decode` may be attacker-influenced. The decoder:
58;;; - checks every length prefix against the remaining buffer BEFORE allocating
59;;; or copying (never pre-allocates N from an untrusted varint);
60;;; - enforces configurable caps (max body length, collection count, nesting
61;;; depth, total decoded size) and rejects — without allocating — on
62;;; violation;
63;;; - uses a bounds-checked cursor, so a truncated or lying frame errors
64;;; cleanly and never reads out of bounds.
65;;;
66;;; Pass a caps record from `make-wire-caps` to tune the limits:
67;;;
68;;; ```scheme
69;;; (wire-decode bytes (make-wire-caps max-depth: 32 max-count: 1000))
70;;; ```
72(define-library (sigil wire)
73 (import (sigil core)
74 (sigil io)
75 (sigil math))
76 (export
77 ;; Codec
78 wire-encode
79 wire-decode
81 ;; Security caps
82 make-wire-caps
83 default-wire-caps)
85 (begin
87 ;; ========== Constants ==========
89 (define MAGIC-0 #x53) ; 'S'
90 (define MAGIC-1 #x57) ; 'W'
91 (define WIRE-VERSION 1)
92 (define WIRE-FLAGS 0)
94 (define TAG-FALSE #x00)
95 (define TAG-TRUE #x01)
96 (define TAG-INT #x02)
97 (define TAG-FLOAT #x03)
98 (define TAG-STRING #x04)
99 (define TAG-BYTEVECTOR #x05)
100 (define TAG-KEYWORD #x06)
101 (define TAG-SYMBOL #x07)
102 (define TAG-CHAR #x08)
103 (define TAG-LIST #x09)
104 (define TAG-DICT #x0A)
105 (define TAG-VECTOR #x0B)
106 (define TAG-ARRAY #x0C)
108 ;; A length/count varint indexes into the buffer, so it can never
109 ;; legitimately need more than a handful of bytes. Cap it hard to bound
110 ;; decode CPU regardless of the value it claims (which is then range-checked
111 ;; against the remaining buffer anyway).
112 (define LEN-VARINT-MAX-BYTES 10)
114 ;; Estimated bytes a single decoded collection slot costs in the host heap
115 ;; (a cons cell / vector slot + overhead). Charged per element toward
116 ;; `max-total` so a collection-heavy frame of tiny elements is bounded by
117 ;; max-total, not merely by frame-size x max-count. A conservative upper
118 ;; bound; it need not be exact, only proportional.
119 (define SLOT-COST 16)
121 ;; ========== Security caps ==========
123 ;;; Build a caps record controlling decode limits. Any omitted field takes
124 ;;; the default from `default-wire-caps`.
125 ;;;
126 ;;; - `max-bytes-len` — largest single string/bytevector body (bytes)
127 ;;; - `max-count` — largest collection (list/vector length, dict pairs)
128 ;;; - `max-depth` — deepest nesting of collections. NOTE: decode is
129 ;;; recursive, so this ALSO bounds host stack depth —
130 ;;; keep it modest (the default 256 is safe). Cranking
131 ;;; it to tens of thousands reintroduces stack-overflow
132 ;;; risk on a hostile deeply-nested frame.
133 ;;; - `max-total` — total decoded heap charged: string/bytevector body
134 ;;; bytes PLUS an estimated per-element cost for every
135 ;;; collection slot. Bounds total decoded memory.
136 ;;; - `max-int-bytes` — largest int payload (zigzag varint bytes), bounds
137 ;;; bignum size
138 (define (make-wire-caps (keys: (max-bytes-len 67108864) ; 64 MiB
139 (max-count 16777216) ; 16 M
140 (max-depth 256)
141 (max-total 268435456) ; 256 MiB
142 (max-int-bytes 1024))) ; ~8192-bit
143 #{ max-bytes-len: max-bytes-len
144 max-count: max-count
145 max-depth: max-depth
146 max-total: max-total
147 max-int-bytes: max-int-bytes })
149 (define default-wire-caps (make-wire-caps))
151 ;; ========== Varint (unsigned LEB128) ==========
153 ;; NOTE: the varint path uses only arithmetic (quotient / remainder / * / +),
154 ;; never bitwise-and / bitwise-ior / arithmetic-shift. Older Sigil bitwise/
155 ;; shift primitives mis-handle values straddling the fixnum<->bignum boundary
156 ;; (round-tripping 2^62 or 7^500 through shift+ior corrupted the value); that
157 ;; VM bug is fixed as of 0.17.18, but the arithmetic form is kept because it
158 ;; is correct on ANY sigil (incl. older and wasm builds) at no real cost.
159 ;; See the wire-format topic note.
161 ;; Write a non-negative integer as unsigned LEB128 to a port.
162 (define (write-uvarint u port)
163 (let loop ((u u))
164 (let ((b (remainder u 128))
165 (rest (quotient u 128)))
166 (if (= rest 0)
167 (write-u8 b port)
168 (begin
169 (write-u8 (+ b 128) port)
170 (loop rest))))))
172 ;; Zigzag-map a signed integer to a non-negative one (bignum-safe).
173 (define (zigzag n)
174 (if (>= n 0)
175 (* n 2)
176 (- (* (- n) 2) 1)))
178 ;; Inverse of `zigzag`.
179 (define (unzigzag u)
180 (if (= 0 (remainder u 2))
181 (quotient u 2)
182 (- (- (quotient u 2)) 1)))
184 ;; ========== Float <-> IEEE-754 bytes ==========
185 ;;
186 ;; The wire float is the raw 8-byte IEEE-754 double, LITTLE-ENDIAN (fixed by
187 ;; the format, independent of host byte order). Sigil-stdlib's native
188 ;; `bytevector-ieee-double-{ref,set!}` do the exact conversion, so every
189 ;; double — normal, subnormal, +/-0.0, +/-inf, NaN — round-trips bit-exactly.
190 ;; Crucially for the trust boundary, `-ref` is NaN-box-safe: it canonicalizes
191 ;; any hostile bit pattern (including ones that would collide with the VM's
192 ;; immediate tag space) to a genuine quiet-NaN flonum, never a type-confused
193 ;; Value. It also bounds-checks the offset/length itself.
195 ;; ========== Encoding ==========
197 ;;; Encode a Sigil value to a self-describing wire bytevector.
198 ;;;
199 ;;; Every value type the seam carries is supported: #f, #t, exact integers
200 ;;; (incl. bignums), doubles, strings, bytevectors, keywords, symbols,
201 ;;; chars, lists, dicts, vectors and arrays. A value that cannot be
202 ;;; represented —
203 ;;; a procedure, a port, a record without a registered codec, an improper
204 ;;; (dotted) list, or a non-real number — is an ENCODE error, never a
205 ;;; silent drop.
206 ;;;
207 ;;; ```scheme
208 ;;; (wire-encode #{ id: 7 tags: #["a" "b"] })
209 ;;; ; => #<bytevector ...>
210 ;;; ```
211 (define (wire-encode value)
212 (: any? -> bytevector?)
213 (let ((port (open-output-bytevector)))
214 (write-u8 MAGIC-0 port)
215 (write-u8 MAGIC-1 port)
216 (write-u8 WIRE-VERSION port)
217 (write-u8 WIRE-FLAGS port)
218 (encode-value value port)
219 (get-output-bytevector port)))
221 ;; Write a length-prefixed UTF-8 / raw body (the memcpy path).
222 (define (encode-bytes tag bv port)
223 (write-u8 tag port)
224 (write-uvarint (bytevector-length bv) port)
225 (write-bytevector bv port))
227 ;; Encode one value (tag + payload) to the port.
228 (define (encode-value value port)
229 (cond
230 ;; Booleans / nil. Order matters: check booleans before numbers so #f
231 ;; and #t never fall through to another branch.
232 ((eq? value #f) (write-u8 TAG-FALSE port))
233 ((eq? value #t) (write-u8 TAG-TRUE port))
234 ;; Exact integers (fixnum + bignum) -> zigzag LEB128.
235 ((exact-integer? value)
236 (write-u8 TAG-INT port)
237 (write-uvarint (zigzag value) port))
238 ;; Any other number is a double (Sigil has no exact rationals; complex
239 ;; numbers, if present, are rejected below).
240 ((and (number? value) (inexact? value))
241 (write-u8 TAG-FLOAT port)
242 (encode-float value port))
243 ;; String / bytevector -> memcpy body.
244 ((string? value)
245 (encode-bytes TAG-STRING (string->utf8 value) port))
246 ((bytevector? value)
247 (encode-bytes TAG-BYTEVECTOR value port))
248 ;; Keyword / symbol -> UTF-8 name.
249 ((keyword? value)
250 (encode-bytes TAG-KEYWORD (string->utf8 (keyword->string value)) port))
251 ((symbol? value)
252 (encode-bytes TAG-SYMBOL (string->utf8 (symbol->string value)) port))
253 ;; Char -> codepoint varint.
254 ((char? value)
255 (write-u8 TAG-CHAR port)
256 (write-uvarint (char->integer value) port))
257 ;; Empty list and proper lists.
258 ((null? value)
259 (write-u8 TAG-LIST port)
260 (write-uvarint 0 port))
261 ((pair? value)
262 (encode-list value port))
263 ;; Vector (R7RS #(...)).
264 ((vector? value)
265 (encode-vector value port))
266 ;; Array (Sigil #[...], the primary bulk sequence type).
267 ((array? value)
268 (encode-array value port))
269 ;; Dict.
270 ((dict? value)
271 (encode-dict value port))
272 (else
273 (error "wire-encode: value is not representable on the wire" value))))
275 (define (encode-float value port)
276 ;; Raw 8-byte IEEE-754 double, little-endian (exact bits, incl. -0.0).
277 (let ((bv (make-bytevector 8 0)))
278 (bytevector-ieee-double-set! bv 0 value 'little)
279 (write-bytevector bv port)))
281 (define (encode-list value port)
282 ;; Walk once: verify the list is proper and count length, collecting the
283 ;; elements. An improper (dotted) tail is an encode error.
284 (let loop ((v value) (items '()) (n 0))
285 (cond
286 ((null? v)
287 (write-u8 TAG-LIST port)
288 (write-uvarint n port)
289 (for-each (lambda (x) (encode-value x port)) (reverse items)))
290 ((pair? v)
291 (loop (cdr v) (cons (car v) items) (+ n 1)))
292 (else
293 (error "wire-encode: improper (dotted) list is not representable" value)))))
295 (define (encode-vector value port)
296 (let ((len (vector-length value)))
297 (write-u8 TAG-VECTOR port)
298 (write-uvarint len port)
299 (let loop ((i 0))
300 (when (< i len)
301 (encode-value (vector-ref value i) port)
302 (loop (+ i 1))))))
304 (define (encode-array value port)
305 (let ((len (array-length value)))
306 (write-u8 TAG-ARRAY port)
307 (write-uvarint len port)
308 (let loop ((i 0))
309 (when (< i len)
310 (encode-value (array-ref value i) port)
311 (loop (+ i 1))))))
313 (define (encode-dict value port)
314 (let ((entries (dict-entries value)))
315 (write-u8 TAG-DICT port)
316 (write-uvarint (length entries) port)
317 (for-each
318 (lambda (pair)
319 (encode-value (car pair) port)
320 (encode-value (cdr pair) port))
321 entries)))
323 ;; ========== Decoding cursor (bounds-checked) ==========
324 ;;
325 ;; The cursor is a mutable vector #(bv len pos total) so a lying/truncated
326 ;; frame errors cleanly instead of reading out of bounds. `total` tracks
327 ;; body bytes allocated so far, checked against the max-total cap.
329 (define (cur-make bv)
330 (vector bv (bytevector-length bv) 0 0))
332 (define (cur-bv c) (vector-ref c 0))
333 (define (cur-len c) (vector-ref c 1))
334 (define (cur-pos c) (vector-ref c 2))
335 (define (cur-remaining c) (- (vector-ref c 1) (vector-ref c 2)))
337 ;; Error unless at least n bytes remain.
338 (define (cur-need! c n)
339 (when (> n (cur-remaining c))
340 (error "wire-decode: truncated frame (buffer underrun)")))
342 ;; Read one byte, advancing the cursor.
343 (define (cur-u8! c)
344 (cur-need! c 1)
345 (let ((b (bytevector-u8-ref (cur-bv c) (cur-pos c))))
346 (vector-set! c 2 (+ (cur-pos c) 1))
347 b))
349 ;; Copy and return the next n bytes (the memcpy path), advancing the cursor.
350 (define (cur-take! c n)
351 (cur-need! c n)
352 (let* ((start (cur-pos c))
353 (slice (bytevector-copy (cur-bv c) start (+ start n))))
354 (vector-set! c 2 (+ start n))
355 slice))
357 ;; Account for n newly-allocated body bytes against the max-total cap.
358 (define (cur-add-total! c n caps)
359 (let ((total (+ (vector-ref c 3) n)))
360 (when (> total (dict-ref caps 'max-total:))
361 (error "wire-decode: total decoded size exceeds cap"))
362 (vector-set! c 3 total)))
364 ;; Read an unsigned LEB128 varint, rejecting one longer than max-bytes.
365 ;; Arithmetic accumulation (result + low7 * mult) keeps bignums correct.
366 (define (read-uvarint c max-bytes)
367 (let loop ((result 0) (mult 1) (count 0))
368 (let ((b (cur-u8! c))
369 (count (+ count 1)))
370 (when (> count max-bytes)
371 (error "wire-decode: varint too long"))
372 (let ((result (+ result (* (remainder b 128) mult))))
373 (if (< b 128)
374 result
375 (loop result (* mult 128) count))))))
377 ;; Read a length/count varint (small cap) and range-check it against the
378 ;; remaining buffer BEFORE it is used to allocate. `min-per` is the minimum
379 ;; bytes each counted element consumes (1 for collections), so a count that
380 ;; could not possibly fit in what remains is rejected without allocating.
381 (define (read-length c what min-per)
382 (let ((n (read-uvarint c LEN-VARINT-MAX-BYTES)))
383 (when (> (* n min-per) (cur-remaining c))
384 (error (string-append "wire-decode: " what " exceeds remaining buffer")))
385 n))
387 ;; ========== Decoding ==========
389 ;;; Decode a wire bytevector produced by `wire-encode` back into a Sigil
390 ;;; value. The optional caps record (default `default-wire-caps`) bounds the
391 ;;; work an untrusted frame can trigger.
392 ;;;
393 ;;; Raises a clean error on any malformed input: bad magic, unknown major
394 ;;; version, unknown tag, truncated body, a length prefix that overruns the
395 ;;; buffer, or a cap violation. It never reads out of bounds.
396 ;;;
397 ;;; ```scheme
398 ;;; (wire-decode (wire-encode #[1 2 3]))
399 ;;; ; => #[1 2 3]
400 ;;; ```
401 (define (wire-decode bv . rest)
402 (: bytevector? any? ... -> any?)
403 (let ((caps (if (null? rest) default-wire-caps (car rest)))
404 (c (cur-make bv)))
405 ;; Header.
406 (unless (and (= (cur-u8! c) MAGIC-0) (= (cur-u8! c) MAGIC-1))
407 (error "wire-decode: bad magic (not a sigil-wire frame)"))
408 (let ((version (cur-u8! c)))
409 (unless (= version WIRE-VERSION)
410 (error "wire-decode: unsupported wire version" version)))
411 (cur-u8! c) ; FLAGS (reserved, ignored)
412 (let ((value (decode-value c caps 0)))
413 ;; Trailing bytes after a complete root value are malformed.
414 (when (> (cur-remaining c) 0)
415 (error "wire-decode: trailing bytes after root value"))
416 value)))
418 ;; Decode one value at the current cursor. `depth` is the current nesting
419 ;; level, checked against max-depth on every collection.
420 (define (decode-value c caps depth)
421 (let ((tag (cur-u8! c)))
422 (cond
423 ((= tag TAG-FALSE) #f)
424 ((= tag TAG-TRUE) #t)
425 ((= tag TAG-INT)
426 (unzigzag (read-uvarint c (dict-ref caps 'max-int-bytes:))))
427 ((= tag TAG-FLOAT) (decode-float c))
428 ;; utf8->string is lenient on malformed UTF-8 (produces replacement
429 ;; chars, never crashes / reads OOB), so a hostile string body is safe.
430 ((= tag TAG-STRING) (utf8->string (decode-body c caps)))
431 ((= tag TAG-BYTEVECTOR) (decode-body c caps))
432 ;; HARDEN-BEFORE-ENCLAVE: string->keyword/string->symbol INTERN the name
433 ;; permanently (the intern table is not GC'd). A hostile remote peer
434 ;; streaming endless unique names exhausts memory over time — the
435 ;; per-frame caps do not bound it. Mitigation (decode-as-string for
436 ;; untrusted transport unless a schema opts in) is a Part-2 transport
437 ;; decision; not gated here because it would break local round-trips.
438 ((= tag TAG-KEYWORD) (string->keyword (utf8->string (decode-body c caps))))
439 ((= tag TAG-SYMBOL) (string->symbol (utf8->string (decode-body c caps))))
440 ((= tag TAG-CHAR) (decode-char c))
441 ((= tag TAG-LIST) (decode-list c caps depth))
442 ((= tag TAG-DICT) (decode-dict c caps depth))
443 ((= tag TAG-VECTOR) (decode-vector c caps depth))
444 ((= tag TAG-ARRAY) (decode-array c caps depth))
445 (else
446 (error "wire-decode: unknown value tag" tag)))))
448 ;; Read a length-prefixed body: check length against the cap and the
449 ;; remaining buffer, account for it, then memcpy it out.
450 (define (decode-body c caps)
451 (let ((n (read-length c "body length" 1)))
452 (when (> n (dict-ref caps 'max-bytes-len:))
453 (error "wire-decode: body length exceeds cap"))
454 (cur-add-total! c n caps)
455 (cur-take! c n)))
457 (define (decode-float c)
458 ;; cur-take! bounds-checks the 8 bytes; bytevector-ieee-double-ref
459 ;; canonicalizes any hostile bit pattern to a safe flonum.
460 (bytevector-ieee-double-ref (cur-take! c 8) 0 'little))
462 (define (decode-char c)
463 (let ((cp (read-uvarint c LEN-VARINT-MAX-BYTES)))
464 ;; integer->char validates the range (rejects > #x10FFFF / surrogates).
465 (integer->char cp)))
467 ;; Read a collection count, enforcing depth and count caps, and charge the
468 ;; container's own slot allocation (k * slot-bytes) toward max-total. depth
469 ;; also bounds host recursion depth (decode is recursive) — see max-depth.
470 (define (decode-count c caps depth what slot-bytes)
471 (when (>= depth (dict-ref caps 'max-depth:))
472 (error "wire-decode: nesting depth exceeds cap"))
473 (let ((k (read-length c what 1)))
474 (when (> k (dict-ref caps 'max-count:))
475 (error "wire-decode: collection count exceeds cap"))
476 (cur-add-total! c (* k slot-bytes) caps)
477 k))
479 (define (decode-list c caps depth)
480 (let ((k (decode-count c caps depth "list count" SLOT-COST)))
481 (let loop ((i 0) (acc '()))
482 (if (= i k)
483 (reverse acc)
484 (loop (+ i 1) (cons (decode-value c caps (+ depth 1)) acc))))))
486 (define (decode-vector c caps depth)
487 (let* ((k (decode-count c caps depth "vector count" SLOT-COST))
488 (v (make-vector k 0)))
489 (let loop ((i 0))
490 (if (= i k)
491 v
492 (begin
493 (vector-set! v i (decode-value c caps (+ depth 1)))
494 (loop (+ i 1)))))))
496 (define (decode-array c caps depth)
497 (let ((k (decode-count c caps depth "array count" SLOT-COST)))
498 (let loop ((i 0) (acc '()))
499 (if (= i k)
500 (list->array (reverse acc))
501 (loop (+ i 1) (cons (decode-value c caps (+ depth 1)) acc))))))
503 (define (decode-dict c caps depth)
504 ;; A dict pair holds two references (key + value), so charge 2 slots each.
505 (let ((k (decode-count c caps depth "dict count" (* 2 SLOT-COST))))
506 ;; Each pair is two values, so it needs at least 2 bytes; tighten the
507 ;; buffer check accordingly.
508 (when (> (* k 2) (cur-remaining c))
509 (error "wire-decode: dict count exceeds remaining buffer"))
510 (let loop ((i 0) (d #{}))
511 (if (= i k)
512 d
513 (let* ((key (decode-value c caps (+ depth 1)))
514 (val (decode-value c caps (+ depth 1))))
515 (loop (+ i 1) (dict-set d key val)))))))))