test/test-wire.sgl — sigil-wire

1;;; Test suite for (sigil wire)

2;;;

3;;; Two halves:

4;;; 1. Round-trip coverage for every value type + edge cases.

5;;; 2. Hostile-input fuzzing of the decoder (the trust boundary): truncated

6;;; frames, lying lengths, cap violations, unknown tags/versions. Each must

7;;; error CLEANLY — no OOB read, no OOM, no spin.

9(import (sigil test)

10 (sigil wire)

11 (sigil core)

12 (sigil math))

14;; ---------- helpers ----------

16;; Round-trip: encode then decode.

17(define (rt v)

18 (wire-decode (wire-encode v)))

20;; Does the thunk raise? (Clean-error probe for hostile inputs.)

21(define (raises? thunk)

22 (guard (e (#t #t))

23 (thunk)

24 #f))

26;; Header bytes for a valid frame: MAGIC "SW", VERSION 1, FLAGS 0.

27(define wire-header (list #x53 #x57 1 0))

29;; Build a bytevector from a list of bytes.

30(define (bytes->bv lst)

31 (apply bytevector lst))

33;; A valid frame carrying the given raw payload bytes.

34(define (frame . payload-bytes)

35 (bytes->bv (append wire-header payload-bytes)))

37;; ============================================================

38;; Round-trip: primitives

39;; ============================================================

41(test-group "round-trip - booleans and nil"

42 (test "false" (assert-equal #f (rt #f)))

43 (test "true" (assert-equal #t (rt #t)))

44 (test "empty list is nil-ish" (assert-equal '() (rt '()))))

46(test-group "round-trip - integers"

47 (test "zero" (assert-equal 0 (rt 0)))

48 (test "one" (assert-equal 1 (rt 1)))

49 (test "small positive" (assert-equal 42 (rt 42)))

50 (test "small negative" (assert-equal -1 (rt -1)))

51 (test "negative" (assert-equal -12345 (rt -12345)))

52 (test "127 boundary" (assert-equal 127 (rt 127)))

53 (test "128 boundary" (assert-equal 128 (rt 128)))

54 (test "large positive bignum" (assert-equal (expt 2 200) (rt (expt 2 200))))

55 (test "large negative bignum" (assert-equal (- (expt 2 200)) (rt (- (expt 2 200)))))

56 (test "huge bignum" (assert-equal (expt 7 500) (rt (expt 7 500))))

57 (test "negative huge bignum" (assert-equal (- (expt 7 500)) (rt (- (expt 7 500))))))

59(test-group "round-trip - floats"

60 (test "pi-ish" (assert-equal 3.14 (rt 3.14)))

61 (test "negative" (assert-equal -2.5 (rt -2.5)))

62 (test "zero" (assert-equal 0.0 (rt 0.0)))

63 (test "one" (assert-equal 1.0 (rt 1.0)))

64 (test "tenth" (assert-equal 0.1 (rt 0.1)))

65 (test "max double" (assert-equal 1.7976931348623157e308 (rt 1.7976931348623157e308)))

66 (test "large" (assert-equal 1e308 (rt 1e308)))

67 (test "small normal" (assert-equal 2.2250738585072014e-308 (rt 2.2250738585072014e-308)))

68 (test "subnormal" (assert-equal 1e-308 (rt 1e-308)))

69 (test "smallest subnormal" (assert-equal 5e-324 (rt 5e-324)))

70 (test "negative small" (assert-equal -0.001 (rt -0.001))))

72(test-group "round-trip - float special values"

73 ;; Sigil has no inf/NaN literals but doubles can be inf/NaN (overflow etc.);

74 ;; the codec must round-trip them bit-exactly.

75 (test "+inf" (assert-equal (expt 2.0 2000) (rt (expt 2.0 2000))))

76 (test "-inf" (assert-equal (- (expt 2.0 2000)) (rt (- (expt 2.0 2000)))))

77 (test "+inf stays infinite" (assert-true (infinite? (rt (expt 2.0 2000)))))

78 (test "-inf stays negative" (assert-true (< (rt (- (expt 2.0 2000))) 0.0)))

79 (test "NaN stays NaN"

80 (assert-true (nan? (rt (- (expt 2.0 2000) (expt 2.0 2000))))))

81 ;; The native IEEE accessor preserves the sign bit, so -0.0 now round-trips

82 ;; bit-exactly. equal? cannot distinguish +/-0.0, so compare the wire bytes:

83 ;; -0.0 and +0.0 must encode to DIFFERENT frames (sign bit set only for -0.0).

84 (test "-0.0 round-trips (decodes to a zero)"

85 (assert-equal 0.0 (rt (- 0.0))))

86 (test "-0.0 preserves its sign bit on the wire (distinct from +0.0)"

87 (assert-false (equal? (wire-encode (- 0.0)) (wire-encode 0.0)))))

89(test-group "decode - hostile float bit patterns (NaN-box safety)"

90 ;; A float body may carry any 8 bytes. bytevector-ieee-double-ref canonicalizes

91 ;; bit patterns that would collide with the VM's immediate tag space to a safe

92 ;; quiet-NaN flonum — never a type-confused Value, crash, or OOB read.

93 (test "tag-zone NaN 0x7FFC... reads as a safe NaN flonum"

94 (let ((r (guard (e (#t 'clean-error))

95 (wire-decode (frame #x03 0 0 0 0 0 0 #xFC #x7F)))))

96 (assert-true (or (eq? r 'clean-error) (and (number? r) (nan? r))))))

97 (test "all-ones float bits read as a safe NaN flonum"

98 (let ((r (guard (e (#t 'clean-error))

99 (wire-decode (frame #x03 #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF)))))

100 (assert-true (or (eq? r 'clean-error) (and (number? r) (nan? r))))))

101 (test "float body truncated to 4 bytes errors cleanly"

102 (assert-true (raises? (lambda () (wire-decode (frame #x03 0 0 0 0)))))))

103

104(test-group "round-trip - strings"

105 (test "empty" (assert-equal "" (rt "")))

106 (test "ascii" (assert-equal "hello" (rt "hello")))

107 (test "spaces and punct" (assert-equal "a, b. c!" (rt "a, b. c!")))

108 (test "2-byte utf8" (assert-equal "héllo" (rt "héllo")))

109 (test "3-byte utf8" (assert-equal "日本語" (rt "日本語")))

110 (test "4-byte utf8 emoji" (assert-equal "🚀🔥" (rt "🚀🔥")))

111 (test "mixed" (assert-equal "λ = π · r² 日 🚀" (rt "λ = π · r² 日 🚀")))

112 (test "embedded null"

113 (let ((s (string #\a (integer->char 0) #\b)))

114 (assert-equal s (rt s)))))

115

116(test-group "round-trip - bytevectors"

117 (test "empty" (assert-equal (bytevector) (rt (bytevector))))

118 (test "bytes" (assert-equal (bytevector 0 1 2 255) (rt (bytevector 0 1 2 255))))

119 (test "all-zero" (assert-equal (make-bytevector 10 0) (rt (make-bytevector 10 0)))))

120

121(test-group "round-trip - keywords and symbols"

122 (test "keyword" (assert-equal 'name: (rt 'name:)))

123 (test "keyword unicode" (assert-equal (string->keyword "café") (rt (string->keyword "café"))))

124 (test "symbol" (assert-equal 'foo-bar (rt 'foo-bar)))

125 (test "symbol unicode" (assert-equal (string->symbol "λ-fn") (rt (string->symbol "λ-fn")))))

126

127(test-group "round-trip - chars"

128 ;; Non-ASCII char literals are built via integer->char (Sigil's reader does

129 ;; not accept multi-byte #\<char> literals).

130 (test "ascii" (assert-equal #\a (rt #\a)))

131 (test "space" (assert-equal #\space (rt #\space)))

132 (test "newline" (assert-equal #\newline (rt #\newline)))

133 (test "greek lambda (955)" (assert-equal (integer->char 955) (rt (integer->char 955))))

134 (test "cjk (26085)" (assert-equal (integer->char 26085) (rt (integer->char 26085))))

135 (test "emoji codepoint (128640)"

136 (assert-equal (integer->char 128640) (rt (integer->char 128640))))

137 (test "null char" (assert-equal (integer->char 0) (rt (integer->char 0))))

138 (test "max codepoint" (assert-equal (integer->char #x10FFFF) (rt (integer->char #x10FFFF)))))

139

140;; ============================================================

141;; Round-trip: collections

142;; ============================================================

143

144(test-group "round-trip - lists"

145 (test "empty" (assert-equal '() (rt '())))

146 (test "ints" (assert-equal '(1 2 3) (rt '(1 2 3))))

147 (test "mixed" (assert-equal (list 1 "two" 3.0 #\4 'five:) (rt (list 1 "two" 3.0 #\4 'five:))))

148 (test "nested" (assert-equal '(1 (2 (3 (4)))) (rt '(1 (2 (3 (4)))))))

149 (test "list of strings" (assert-equal '("a" "bb" "ccc") (rt '("a" "bb" "ccc")))))

150

151(test-group "round-trip - vectors (R7RS #())"

152 (test "empty" (assert-equal (vector) (rt (vector))))

153 (test "ints" (assert-equal #(1 2 3) (rt #(1 2 3))))

154 (test "mixed" (assert-equal (vector 1 "two" 3.0 #t) (rt (vector 1 "two" 3.0 #t))))

155 (test "nested" (assert-equal #(#(1 2) #(3 4)) (rt #(#(1 2) #(3 4)))))

156 (test "stays a vector, not an array"

157 (assert-true (vector? (rt #(1 2 3))))))

158

159(test-group "round-trip - arrays (Sigil #[])"

160 (test "empty" (assert-equal #[] (rt #[])))

161 (test "ints" (assert-equal #[1 2 3] (rt #[1 2 3])))

162 (test "mixed" (assert-equal #[1 "two" 3.0 #t] (rt #[1 "two" 3.0 #t])))

163 (test "nested" (assert-equal #[#[1 2] #[3 4]] (rt #[#[1 2] #[3 4]])))

164 (test "stays an array, not a vector"

165 (assert-true (array? (rt #[1 2 3]))))

166 (test "array and vector are distinct on the wire"

167 (assert-false (equal? (wire-encode #[1 2 3]) (wire-encode #(1 2 3))))))

168

169(test-group "round-trip - dicts"

170 (test "empty" (assert-equal #{} (rt #{})))

171 (test "simple" (assert-equal #{ a: 1 } (rt #{ a: 1 })))

172 (test "multi" (assert-equal #{ name: "Alice" age: 30 } (rt #{ name: "Alice" age: 30 })))

173 (test "nested dict" (assert-equal #{ outer: #{ inner: 42 } } (rt #{ outer: #{ inner: 42 } })))

174 (test "dict with collections"

175 (assert-equal #{ items: #[1 2 3] tags: (list "x" "y") }

176 (rt #{ items: #[1 2 3] tags: (list "x" "y") }))))

177

178(test-group "round-trip - deeply nested mixed"

179 (test "structure like a directory listing"

180 (let ((v #{ entries: #[ #{ name: "a.txt" size: 100 dir: #f }

181 #{ name: "sub" size: 0 dir: #t } ]

182 total: 2 }))

183 (assert-equal v (rt v))))

184 (test "list/dict/vector interleaved"

185 (let ((v (list #{ k: #[1 (list 2 3) #{ deep: "yes" }] }

186 'sym

187 #\x

188 (bytevector 9 8 7))))

189 (assert-equal v (rt v)))))

190

191;; ============================================================

192;; Encode errors: non-representable values

193;; ============================================================

194

195(test-group "encode - non-representable is an error, not a drop"

196 (test "procedure" (assert-true (raises? (lambda () (wire-encode car)))))

197 (test "improper list" (assert-true (raises? (lambda () (wire-encode (cons 1 2))))))

198 (test "procedure nested in a list"

199 (assert-true (raises? (lambda () (wire-encode (list 1 2 car))))))

200 (test "procedure nested in a dict value"

201 (assert-true (raises? (lambda () (wire-encode #{ f: car }))))))

202

203;; ============================================================

204;; Hostile-input fuzzing of the decoder (trust boundary)

205;; ============================================================

206

207(test-group "decode - malformed header"

208 (test "empty buffer" (assert-true (raises? (lambda () (wire-decode (bytevector))))))

209 (test "too short for header"

210 (assert-true (raises? (lambda () (wire-decode (bytevector #x53))))))

211 (test "bad magic byte 0"

212 (assert-true (raises? (lambda () (wire-decode (bytes->bv (list #x00 #x57 1 0 #x00)))))))

213 (test "bad magic byte 1"

214 (assert-true (raises? (lambda () (wire-decode (bytes->bv (list #x53 #x00 1 0 #x00)))))))

215 (test "unknown version"

216 (assert-true (raises? (lambda () (wire-decode (bytes->bv (list #x53 #x57 99 0 #x00))))))))

217

218(test-group "decode - unknown tags"

219 (test "unknown tag 0x7F" (assert-true (raises? (lambda () (wire-decode (frame #x7F))))))

220 (test "unknown tag 0xFF" (assert-true (raises? (lambda () (wire-decode (frame #xFF))))))

221 (test "just past known range" (assert-true (raises? (lambda () (wire-decode (frame #x0C)))))))

222

223(test-group "decode - truncated frames"

224 (test "tag but no payload (int)"

225 (assert-true (raises? (lambda () (wire-decode (frame #x02))))))

226 (test "string claims 5 bytes, gives 2"

227 (assert-true (raises? (lambda () (wire-decode (frame #x04 5 #x61 #x62))))))

228 (test "bytevector claims 10, gives 0"

229 (assert-true (raises? (lambda () (wire-decode (frame #x05 10))))))

230 (test "float with only 4 of 8 bytes"

231 (assert-true (raises? (lambda () (wire-decode (frame #x03 0 0 0 0))))))

232 (test "char varint truncated (continuation then EOF)"

233 (assert-true (raises? (lambda () (wire-decode (frame #x08 #x80))))))

234 (test "list claims 3 elements, gives 1"

235 (assert-true (raises? (lambda () (wire-decode (frame #x09 3 #x01))))))

236 (test "dict claims 2 pairs, gives nothing"

237 (assert-true (raises? (lambda () (wire-decode (frame #x0A 2)))))))

238

239(test-group "decode - lying length prefixes (claim huge, provide few)"

240 (test "string claims ~2 billion bytes"

241 ;; varint for 0xF0F0F0F0: bytes 0xF0 0xE1 0xC3 0x87 0x0F

242 (assert-true (raises? (lambda ()

243 (wire-decode (frame #x04 #xF0 #xE1 #xC3 #x87 #x0F #x61))))))

244 (test "list claims ~2 billion elements"

245 (assert-true (raises? (lambda ()

246 (wire-decode (frame #x09 #xF0 #xE1 #xC3 #x87 #x0F))))))

247 (test "dict claims huge pair count"

248 (assert-true (raises? (lambda ()

249 (wire-decode (frame #x0A #xFF #xFF #xFF #xFF #x0F)))))))

250

251(test-group "decode - varint abuse"

252 (test "int with endless continuation bytes errors (does not spin/OOM)"

253 ;; 1030 continuation bytes with no terminator, past default max-int-bytes.

254 (assert-true (raises? (lambda ()

255 (wire-decode (bytes->bv (append wire-header (list #x02)

256 (make-continuation-bytes 1030))))))))

257 (test "length varint too long"

258 ;; 12 continuation bytes for a body length; exceeds LEN-VARINT-MAX-BYTES.

259 (assert-true (raises? (lambda ()

260 (wire-decode (bytes->bv (append wire-header (list #x04)

261 (make-continuation-bytes 12)))))))))

262

263(test-group "decode - malformed string bodies"

264 ;; F4: a string body carrying invalid UTF-8 must have defined behavior — a

265 ;; string (lenient decode) or a clean error — never a crash or OOB read.

266 (test "invalid UTF-8 (bad lead bytes)"

267 (let ((r (guard (e (#t 'clean-error))

268 (wire-decode (frame #x04 3 #xFF #xFE #x28)))))

269 (assert-true (or (string? r) (eq? r 'clean-error)))))

270 (test "invalid UTF-8 (truncated multibyte)"

271 (let ((r (guard (e (#t 'clean-error))

272 (wire-decode (frame #x04 2 #xE2 #x82)))))

273 (assert-true (or (string? r) (eq? r 'clean-error)))))

274 (test "invalid UTF-8 in a keyword body"

275 (let ((r (guard (e (#t 'clean-error))

276 (wire-decode (frame #x06 2 #xC3 #x28)))))

277 (assert-true (or (keyword? r) (eq? r 'clean-error))))))

278

279(test-group "decode - trailing garbage"

280 (test "extra byte after a complete value"

281 (assert-true (raises? (lambda () (wire-decode (frame #x01 #x99))))))

282 (test "second value after root"

283 (assert-true (raises? (lambda () (wire-decode (frame #x00 #x01)))))))

284

285;; ============================================================

286;; Cap enforcement

287;; ============================================================

288

289(test-group "caps - body length"

290 (test "oversized string rejected by tiny cap"

291 (let ((bytes (wire-encode "this string is definitely longer than eight bytes")))

292 (assert-true (raises? (lambda ()

293 (wire-decode bytes (make-wire-caps max-bytes-len: 8)))))))

294 (test "within cap decodes fine"

295 (let ((bytes (wire-encode "short")))

296 (assert-equal "short" (wire-decode bytes (make-wire-caps max-bytes-len: 100))))))

297

298(test-group "caps - collection count"

299 (test "too many list elements rejected"

300 (let ((bytes (wire-encode '(1 2 3 4 5 6 7 8 9 10))))

301 (assert-true (raises? (lambda ()

302 (wire-decode bytes (make-wire-caps max-count: 3)))))))

303 (test "too many dict pairs rejected"

304 (let ((bytes (wire-encode #{ a: 1 b: 2 c: 3 })))

305 (assert-true (raises? (lambda ()

306 (wire-decode bytes (make-wire-caps max-count: 2)))))))

307 (test "within count cap decodes"

308 (let ((bytes (wire-encode '(1 2 3))))

309 (assert-equal '(1 2 3) (wire-decode bytes (make-wire-caps max-count: 10))))))

310

311(test-group "caps - nesting depth"

312 (test "too-deep nesting rejected"

313 (let ((deep (build-nested-list 300)))

314 (assert-true (raises? (lambda ()

315 (wire-decode (wire-encode deep) (make-wire-caps max-depth: 64)))))))

316 (test "shallow nesting within cap decodes"

317 (let ((shallow (build-nested-list 10)))

318 (assert-equal shallow

319 (wire-decode (wire-encode shallow) (make-wire-caps max-depth: 64))))))

320

321(test-group "caps - total decoded size"

322 (test "total body bytes over cap rejected"

323 (let ((bytes (wire-encode (list "aaaa" "bbbb" "cccc" "dddd"))))

324 (assert-true (raises? (lambda ()

325 (wire-decode bytes (make-wire-caps max-total: 8)))))))

326 (test "generous total cap decodes"

327 (let ((v (list "aaaa" "bbbb")))

328 (assert-equal v (wire-decode (wire-encode v) (make-wire-caps max-total: 1000)))))

329 ;; F1 regression: a collection of TINY elements (no bodies) must still be

330 ;; bounded by max-total — the container's own slot allocation is charged.

331 (test "list of tiny elements charges slots toward max-total"

332 (let ((bytes (wire-encode (list 1 2 3 4 5 6 7 8 9 10))))

333 (assert-true (raises? (lambda ()

334 (wire-decode bytes (make-wire-caps max-total: 8)))))))

335 (test "vector of tiny elements charges slots toward max-total"

336 (let ((bytes (wire-encode (vector 1 2 3 4 5 6 7 8 9 10))))

337 (assert-true (raises? (lambda ()

338 (wire-decode bytes (make-wire-caps max-total: 8)))))))

339 (test "array of tiny elements charges slots toward max-total"

340 (let ((bytes (wire-encode #[1 2 3 4 5 6 7 8 9 10])))

341 (assert-true (raises? (lambda ()

342 (wire-decode bytes (make-wire-caps max-total: 8)))))))

343 (test "dict of tiny pairs charges slots toward max-total"

344 (let ((bytes (wire-encode #{ a: 1 b: 2 c: 3 d: 4 })))

345 (assert-true (raises? (lambda ()

346 (wire-decode bytes (make-wire-caps max-total: 8)))))))

347 (test "tiny collection within a generous total cap still decodes"

348 (let ((v (list 1 2 3)))

349 (assert-equal v (wire-decode (wire-encode v) (make-wire-caps max-total: 1000))))))

350

351(test-group "caps - int magnitude"

352 (test "bignum over max-int-bytes rejected"

353 (let ((bytes (wire-encode (expt 2 4000))))

354 (assert-true (raises? (lambda ()

355 (wire-decode bytes (make-wire-caps max-int-bytes: 4)))))))

356 (test "bignum within cap decodes"

357 (let ((n (expt 2 200)))

358 (assert-equal n (wire-decode (wire-encode n) (make-wire-caps max-int-bytes: 1024))))))

359

360;; ---------- helpers used above (defined after; Sigil hoists defines) ----------

361

362(define (make-continuation-bytes n)

363 (let loop ((i 0) (acc '()))

364 (if (= i n) acc (loop (+ i 1) (cons #x80 acc)))))

365

366(define (build-nested-list depth)

367 (let loop ((n depth) (v '()))

368 (if (= n 0) v (loop (- n 1) (list v)))))