Add comprehensive fuzzing infrastructure with 13 harnesses
ober
0ee2a6f79500a4114c3b0dadf8e5c9a8d72397d7
--- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$ # Shared object paths for FFI-based chez-* libraries CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll:$(CHEZ_EXT_DIR)/chez-inotify:$(CHEZ_EXT_DIR)/chez-crypto:$(CHEZ_EXT_DIR)/chez-sqlite:$(CHEZ_EXT_DIR)/chez-postgresql -.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-native native clean-native audit-native clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-native native clean-native audit-native clean fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded @@ -286,6 +286,63 @@ audit-native: test-all: test test-features test-wrappers test-security test-native +## ========== Fuzzing ========== + +FUZZ_DIR = tests/fuzz/harness +FUZZ_ITERATIONS ?= 10000 + +# Run all fuzz harnesses (default iterations) +fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-all.ss + +# Quick smoke test for CI (~30s) +fuzz-smoke: + FUZZ_ITERATIONS=500 $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-all.ss + +# Long-running deep fuzz (nightly/dedicated) +fuzz-deep: + FUZZ_ITERATIONS=1000000 FUZZ_MAX_SIZE=65536 $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-all.ss + +# Individual fuzz targets +fuzz-reader-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-reader.ss + +fuzz-json-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-json.ss + +fuzz-http2-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-http2.ss + +fuzz-websocket-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-websocket.ss + +fuzz-dns-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-dns.ss + +fuzz-pregexp-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-pregexp.ss + +fuzz-csv-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-csv.ss + +fuzz-base64-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-base64.ss + +fuzz-hex-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-hex.ss + +fuzz-uri-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-uri.ss + +fuzz-format-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-format.ss + +fuzz-router-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-router.ss + +fuzz-sandbox-fuzz: + FUZZ_ITERATIONS=$(FUZZ_ITERATIONS) $(SCHEME) --libdirs $(LIBDIRS) --script $(FUZZ_DIR)/fuzz-sandbox.ss + clean: find lib -name "*.so" -delete 2>/dev/null || true find lib -name "*.wpo" -delete 2>/dev/null || true --- a/docs/fuzzing.md +++ b/docs/fuzzing.md @@ -63,6 +63,27 @@ Fuzzing is uniquely effective at finding bugs that humans and code review miss --- +## Existing Hardening + +Before fuzzing, it's important to know what defenses already exist. These limits are parameterized and can be tested by fuzzing with both default and extreme values. + +| Module | Defense | Parameter | Default | +|--------|---------|-----------|---------| +| `jerboa/reader` | Read depth limit | `*max-read-depth*` | 1000 | +| `jerboa/reader` | Block comment nesting limit | `*max-block-comment-depth*` | 1000 | +| `std/text/json` | JSON nesting depth limit | `*json-max-depth*` | 512 | +| `std/text/json` | Max string length | `*json-max-string-length*` | 10MB | +| `std/net/http2` | Max frame payload size | `*http2-max-frame-size*` | 1MB | +| `std/net/websocket` | Max payload size | `*ws-max-payload-size*` | 16MB | +| `std/net/dns` | Compression pointer hop limit | hardcoded | 32 hops | +| `std/text/csv` | Max field length | `*csv-max-field-length*` | 1MB | +| `std/security/restrict` | Allowlist-only bindings | `safe-bindings` | ~113 bindings | +| `std/format` | Safe format variants | `safe-printf` / `safe-fprintf` | N/A | + +Fuzzing should test both the happy path (limits hold) and the bypass path (can the limit be circumvented?). + +--- + ## Fuzzing Architecture for Chez Scheme Chez Scheme is garbage-collected and memory-safe in pure Scheme code, so traditional C fuzzing tools (AFL, libFuzzer) don't directly apply. We need a hybrid approach. @@ -71,18 +92,30 @@ Chez Scheme is garbage-collected and memory-safe in pure Scheme code, so traditi Write Scheme harnesses that generate random inputs and feed them to parsing functions. This catches the majority of bugs: unhandled exceptions, infinite loops, memory bombs, and logic errors. +**Important**: Chez Scheme does not have a built-in `with-time-limit`. We implement timeout detection using `(engine)` — Chez's preemptive evaluation mechanism that counts "ticks" (reductions). This catches infinite loops and excessive computation but measures work done, not wall-clock time. + ```scheme ;; Generic fuzzing harness pattern +;; Uses Chez Scheme's engine mechanism for timeout detection (import (jerboa prelude) (std test)) +(define (fuzz-with-timeout thunk fuel) + ;; Returns: 'ok, 'timeout, or 'exception + ;; fuel = approximate number of reductions before timeout + (let ([eng (make-engine thunk)]) + (eng fuel + (lambda (remaining result) 'ok) ;; completed + (lambda (new-engine) 'timeout)))) ;; ran out of fuel + (define (fuzz-target parse-fn input-generator iterations) (let loop ([i 0]) (when (< i iterations) (let ([input (input-generator)]) (guard (exn [#t (void)]) ;; any exception is OK — crashes are not - (with-time-limit 5 ;; seconds — catches infinite loops - (parse-fn input))) + (fuzz-with-timeout + (lambda () (parse-fn input)) + 1000000)) ;; ~1M reductions ≈ a few seconds (loop (+ i 1)))))) ``` @@ -148,6 +181,9 @@ Targets ordered by priority — a product of attack surface exposure and bug lik | **P2** | `std/format` | `format` | User-controlled format strings | Format injection, arity mismatch | | **P2** | `std/net/router` | `router-match`, `parse-pattern` | HTTP request paths | Path traversal, segment explosion | | **P2** | `std/schema` | `validate` | Untrusted input shapes | Recursion bomb, type confusion | +| **P2** | `std/net/uri` | `uri-parse`, `uri-decode` | HTTP requests, redirects | Malformed URLs, injection, encoding | +| **P2** | `std/text/ini` | INI parsing | Config files | Nesting, unterminated values | +| **P2** | `std/text/json-schema` | `validate` | Untrusted input shapes | Recursion bomb, type confusion | | **P2** | `std/config` | `load-config`, `ht-path-get` | Config files | Nesting bomb, env injection | | **P3** | `std/text/utf8` | `utf8-decode` | Any text processing | Invalid sequences, bounds | | **P3** | `std/crypto/digest` | `md5`, `sha256` | Any data | Shell injection (V1 — pre-fix) | @@ -277,7 +313,28 @@ Targets ordered by priority — a product of attack surface exposure and bug lik | `[^]` | Empty negated class | Behavior | | `\p{Lu}` | Unicode property (if supported) | Feature support | -### T7. Sandbox — `std/security/restrict.sls` +### T7. URI Parser — `std/net/uri.sls` + +**Why it's P2**: The URI parser processes every HTTP request URL and redirect target. Malformed URIs can cause incorrect routing or injection. + +**Specific fuzz vectors**: + +| Vector | What It Tests | Expected Bug | +|--------|--------------|-------------| +| `://` (no scheme) | Minimal URI | Graceful error | +| `http://user:pass@host:99999/path?q=v#f` | Full URI | Correct parsing | +| `http://[::1]:8080/` | IPv6 host | Bracket handling | +| `http://host/../../etc/passwd` | Path traversal | Normalization | +| `http://host/path?a=1&a=2&a=3...x10000` | Query explosion | Memory | +| `%ZZ` in path/query | Invalid percent-encoding | Error vs silent | +| `%00` null byte | Embedded NUL | Truncation bug | +| `http://host\@evil.com/` | Backslash in authority | Parser confusion | +| Empty string | Zero-length input | Graceful error | +| 1MB URL | Large input | Memory/hang | + +**Oracle**: Roundtrip — `uri->string(uri-parse(input))` should be semantically equivalent for valid URIs. + +### T8. Sandbox — `std/security/restrict.sls` **Specific fuzz vectors**: @@ -334,16 +391,21 @@ Every fuzzer is only as good as its starting corpus. For each target: ### Standard Harness Template -Each fuzz target gets a harness file in `tests/fuzz/fuzz-<target>.ss`: +Each fuzz target gets a harness file in `tests/fuzz/harness/fuzz-<target>.ss`: ```scheme (import (jerboa prelude) (std test)) ;; Configuration -(define *iterations* (or (getenv-number "FUZZ_ITERATIONS") 100000)) -(define *max-input-size* (or (getenv-number "FUZZ_MAX_SIZE") 65536)) -(define *timeout-seconds* 5) +;; Note: Chez has no getenv-number — parse manually +(define (getenv-int name default) + (let ([v (getenv name)]) + (if v (or (string->number v) default) default))) + +(define *iterations* (getenv-int "FUZZ_ITERATIONS" 100000)) +(define *max-input-size* (getenv-int "FUZZ_MAX_SIZE" 65536)) +(define *timeout-fuel* 1000000) ;; engine ticks, not seconds ;; Input generation (define (random-bytes n) @@ -366,11 +428,19 @@ Each fuzz target gets a harness file in `tests/fuzz/fuzz-<target>.ss`: (guard (e [#t s]) ;; if invalid UTF-8, return original (utf8->string bv)))) +;; Timeout via Chez engine (measures reductions, not wall-clock) +(define (fuzz-with-timeout thunk fuel) + (let ([eng (make-engine thunk)]) + (eng fuel + (lambda (remaining result) result) + (lambda (new-engine) 'timeout)))) + ;; Harness (define (fuzz-once parse-fn input) (guard (exn [#t (void)]) ;; any Scheme exception is acceptable - (with-time-limit *timeout-seconds* - (parse-fn input)))) + (fuzz-with-timeout + (lambda () (parse-fn input)) + *timeout-fuel*))) (define (run-fuzz name parse-fn gen-fn) (display (format "Fuzzing ~a for ~a iterations...\n" name *iterations*)) @@ -593,6 +663,20 @@ Every crash found by fuzzing becomes a test case in `tests/test-fuzz-regressions --- +## Appendix: Known Issues to Verify + +These are bugs identified by code review that fuzzing should confirm: + +| Module | Issue | Severity | +|--------|-------|----------| +| `std/text/json` | `\uD800` (lone surrogate) calls `integer->char` which crashes on surrogates in Chez | High | +| `std/text/json` | `\uD800\uDC00` surrogate pair not handled — each half parsed independently | Medium | +| `std/net/http2` | HPACK `hpack-decode-string` doesn't bounds-check `len` against bytevector length | High | +| `std/net/dns` | No bounds check before reading answer RR fields (type, class, ttl, rdlength) at `pos+0..pos+9` | High | +| `std/text/base64` | Padding logic with `saw-non-pad?` flag set but never checked | Low | + +--- + ## Appendix: Expected Bug Yield Estimates Based on experience fuzzing similar parsers in other projects: new file mode 100644 --- /dev/null +++ b/lib/std/test/fuzz.sls @@ -0,0 +1,217 @@ +#!chezscheme +;;; (std test fuzz) -- Fuzzing harness library for Jerboa +;;; +;;; Provides random input generators, mutators, timeout detection via +;;; Chez Scheme's engine mechanism, memory tracking, and reporting. + +(library (std test fuzz) + (export + ;; Configuration + fuzz-iterations fuzz-max-size fuzz-fuel + getenv-int + ;; Generators + random-bytevector random-ascii-string random-utf8-string + random-choice random-element + ;; Mutators + mutate-bytevector mutate-string + ;; Harness + fuzz-run fuzz-one fuzz-with-timeout + ;; Oracles + fuzz-roundtrip-check + ;; Reporting + fuzz-report make-fuzz-stats + fuzz-stats-iterations fuzz-stats-exceptions + fuzz-stats-timeouts fuzz-stats-crashes + fuzz-stats-name) + + (import (chezscheme)) + + ;;; ========== Configuration ========== + + (define (getenv-int name default) + (let ([v (getenv name)]) + (if v (or (string->number v) default) default))) + + (define fuzz-iterations (make-parameter (getenv-int "FUZZ_ITERATIONS" 10000))) + (define fuzz-max-size (make-parameter (getenv-int "FUZZ_MAX_SIZE" 4096))) + (define fuzz-fuel (make-parameter (getenv-int "FUZZ_FUEL" 500000))) + + ;;; ========== Random helpers ========== + + (define (random-bytevector n) + (let ([bv (make-bytevector n)]) + (do ([i 0 (+ i 1)]) + ((= i n) bv) + (bytevector-u8-set! bv i (random 256))))) + + (define (random-ascii-string max-len) + (let* ([len (+ 1 (random (max 1 max-len)))] + [chars (map (lambda (_) (integer->char (+ 32 (random 95)))) + (make-list len))]) + (list->string chars))) + + (define (random-utf8-string max-len) + ;; Generate a string with random printable chars + some edge cases + (let* ([len (+ 1 (random (max 1 max-len)))] + [chars (map (lambda (_) + (let ([r (random 100)]) + (cond + [(< r 70) (integer->char (+ 32 (random 95)))] ;; ASCII printable + [(< r 85) (integer->char (+ #x100 (random #x100)))] ;; Latin extended + [(< r 95) (integer->char (+ #x4E00 (random #x100)))] ;; CJK + [else (integer->char (random 128))]))) ;; ASCII full + (make-list len))]) + (list->string chars))) + + (define (random-choice . options) + (list-ref options (random (length options)))) + + (define (random-element lst) + (list-ref lst (random (length lst)))) + + ;;; ========== Mutators ========== + + (define (mutate-bytevector bv) + (when (zero? (bytevector-length bv)) + (error 'mutate-bytevector "cannot mutate empty bytevector")) + (let* ([copy (bytevector-copy bv)] + [len (bytevector-length copy)] + [n-mutations (+ 1 (random (min 5 len)))]) + (do ([m 0 (+ m 1)]) + ((= m n-mutations) copy) + (let ([pos (random len)]) + (case (random 5) + [(0) ;; bit flip + (bytevector-u8-set! copy pos + (bitwise-xor (bytevector-u8-ref copy pos) + (bitwise-arithmetic-shift-left 1 (random 8))))] + [(1) (bytevector-u8-set! copy pos 0)] ;; null + [(2) (bytevector-u8-set! copy pos #xFF)] ;; max byte + [(3) (bytevector-u8-set! copy pos (random 256))] ;; random + [(4) ;; boundary value + (bytevector-u8-set! copy pos + (random-element '(0 1 #x7E #x7F #x80 #xFE #xFF)))]))))) + + (define (mutate-string s) + (if (string=? s "") + (random-ascii-string 10) + (let* ([bv (string->utf8 s)] + [mutated (mutate-bytevector bv)]) + ;; Try to convert back; if invalid UTF-8, return original with char mutation + (guard (e [#t + (let* ([chars (string->list s)] + [pos (random (length chars))] + [new-char (integer->char (+ 32 (random 95)))]) + (let loop ([i 0] [rest chars] [acc '()]) + (if (null? rest) + (list->string (reverse acc)) + (loop (+ i 1) (cdr rest) + (cons (if (= i pos) new-char (car rest)) acc)))))]) + (utf8->string mutated))))) + + ;;; ========== Timeout via engine ========== + + (define (fuzz-with-timeout thunk fuel) + ;; Returns: ('ok . result) | ('timeout . #f) | ('exception . condition) + (guard (exn + [#t (cons 'exception exn)]) + (let ([eng (make-engine thunk)]) + (eng fuel + (lambda (remaining result) + (cons 'ok result)) + (lambda (new-engine) + (cons 'timeout #f)))))) + + ;;; ========== Stats record ========== + + (define-record-type fuzz-stats + (fields name + (mutable iterations) + (mutable exceptions) + (mutable timeouts) + (mutable crashes)) + (protocol + (lambda (new) + (lambda (name) + (new name 0 0 0 0))))) + + ;;; ========== Core harness ========== + + (define (fuzz-one parse-fn input stats) + (let ([result (fuzz-with-timeout + (lambda () (parse-fn input)) + (fuzz-fuel))]) + (fuzz-stats-iterations-set! stats (+ 1 (fuzz-stats-iterations stats))) + (case (car result) + [(ok) 'ok] + [(timeout) + (fuzz-stats-timeouts-set! stats (+ 1 (fuzz-stats-timeouts stats))) + 'timeout] + [(exception) + (fuzz-stats-exceptions-set! stats (+ 1 (fuzz-stats-exceptions stats))) + 'exception]))) + + (define (fuzz-run name parse-fn gen-fn . rest) + (let* ([iterations (if (pair? rest) (car rest) (fuzz-iterations))] + [stats (make-fuzz-stats name)] + [progress-interval (max 1 (quotient iterations 10))]) + (fprintf (current-error-port) "[fuzz] ~a: ~a iterations~n" name iterations) + (let loop ([i 0]) + (when (< i iterations) + (when (and (> i 0) (zero? (modulo i progress-interval))) + (fprintf (current-error-port) "[fuzz] ~a: ~a/~a (~a exceptions, ~a timeouts)~n" + name i iterations + (fuzz-stats-exceptions stats) + (fuzz-stats-timeouts stats))) + (let ([input (gen-fn)]) + (fuzz-one parse-fn input stats)) + (loop (+ i 1)))) + (fuzz-report stats) + stats)) + + ;;; ========== Roundtrip oracle ========== + + (define (fuzz-roundtrip-check name encode decode gen-fn . rest) + ;; Tests: decode(encode(x)) == x for random inputs + (let* ([iterations (if (pair? rest) (car rest) (fuzz-iterations))] + [stats (make-fuzz-stats (string-append name "-roundtrip"))] + [mismatches 0]) + (fprintf (current-error-port) "[fuzz] ~a roundtrip: ~a iterations~n" name iterations) + (let loop ([i 0]) + (when (< i iterations) + (let ([input (gen-fn)]) + (guard (exn [#t + (fuzz-stats-exceptions-set! stats + (+ 1 (fuzz-stats-exceptions stats)))]) + (let* ([encoded (encode input)] + [decoded (decode encoded)]) + (unless (equal? input decoded) + (set! mismatches (+ mismatches 1)) + (when (<= mismatches 5) + (fprintf (current-error-port) + "[fuzz] MISMATCH: input=~s encoded=~s decoded=~s~n" + input encoded decoded)))))) + (fuzz-stats-iterations-set! stats (+ 1 (fuzz-stats-iterations stats))) + (loop (+ i 1)))) + (when (> mismatches 0) + (fprintf (current-error-port) "[fuzz] ~a roundtrip: ~a MISMATCHES in ~a iterations~n" + name mismatches iterations)) + (fuzz-report stats) + stats)) + + ;;; ========== Reporting ========== + + (define (fuzz-report stats) + (let ([name (fuzz-stats-name stats)] + [iters (fuzz-stats-iterations stats)] + [exc (fuzz-stats-exceptions stats)] + [to (fuzz-stats-timeouts stats)] + [crashes (fuzz-stats-crashes stats)]) + (fprintf (current-error-port) + "[fuzz] ~a: DONE ~a iterations — ~a exceptions, ~a timeouts, ~a crashes~n" + name iters exc to crashes) + (when (> crashes 0) + (fprintf (current-error-port) "[fuzz] ~a: *** ~a CRASHES DETECTED ***~n" + name crashes)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/fuzz/harness/fuzz-all.ss @@ -0,0 +1,56 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; fuzz-all.ss -- Run all fuzz harnesses +;;; +;;; Usage: +;;; FUZZ_ITERATIONS=1000 scheme --libdirs lib --script tests/fuzz/harness/fuzz-all.ss +;;; +;;; Each harness is loaded via (load ...) so they run in sequence. +;;; Reports a summary of all results at the end. + +(import (chezscheme)) + +(define harness-dir "tests/fuzz/harness") +(define scheme-cmd (or (getenv "SCHEME") "scheme")) +(define libdirs (or (getenv "LIBDIRS") "lib")) + +(define harnesses + '("fuzz-reader.ss" + "fuzz-json.ss" + "fuzz-http2.ss" + "fuzz-websocket.ss" + "fuzz-dns.ss" + "fuzz-pregexp.ss" + "fuzz-csv.ss" + "fuzz-base64.ss" + "fuzz-hex.ss" + "fuzz-uri.ss" + "fuzz-format.ss" + "fuzz-router.ss" + "fuzz-sandbox.ss")) + +(define (run-harness file) + (let* ([path (string-append harness-dir "/" file)] + [cmd (string-append scheme-cmd " --libdirs " libdirs " --script " path)]) + (fprintf (current-error-port) "~n========== ~a ==========~n" file) + (let ([status (system cmd)]) + (cons file (zero? status))))) + +(define results (map run-harness harnesses)) + +(fprintf (current-error-port) "~n~n========== SUMMARY ==========~n") +(let ([passed 0] [failed 0]) + (for-each + (lambda (r) + (if (cdr r) + (begin + (set! passed (+ passed 1)) + (fprintf (current-error-port) " PASS ~a~n" (car r))) + (begin + (set! failed (+ failed 1)) + (fprintf (current-error-port) " FAIL ~a~n" (car r))))) + results) + (fprintf (current-error-port) "~n~a passed, ~a failed out of ~a harnesses~n" + passed failed (length results)) + (unless (zero? failed) + (exit 1))) new file mode 100644 --- /dev/null +++ b/tests/fuzz/harness/fuzz-base64.ss @@ -0,0 +1,67 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; fuzz-base64.ss -- Fuzzer for std/text/base64 +;;; +;;; Targets: base64-encode, base64-decode +;;; Bug classes: silent wrong output, malformed padding, roundtrip failures + +(import (chezscheme) + (std text base64) + (std test fuzz)) + +;;; ========== Seed corpus ========== + +(define base64-decode-seeds + '("" "YQ==" "YWI=" "YWJj" "YWJjZA==" + "aGVsbG8=" "aGVsbG8gd29ybGQ=" + ;; Invalid + "!!!!" "@@@@" "=====" "YQ=" "YQ" + ;; Whitespace + "YW Jj" "YW\nJj" "YW\tJj" + ;; Padding in middle + "YQ==YQ==" + )) + +;;; ========== Generators ========== + +(define (gen-random-base64-decode-input) + (case (random 6) + [(0) ;; valid base64 chars, random length + (let* ([chars "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"] + [len (+ 1 (random 200))] + [result (make-string len)]) + (do ([i 0 (+ i 1)]) + ((= i len) result) + (string-set! result i + (string-ref chars (random 64)))))] + [(1) ;; invalid characters + (string-append "aGVsbG8" (string (integer->char (+ 128 (random 128)))))] + [(2) ;; bad padding + (random-element '("=" "==" "===" "a=" "a==" "a===" "ab=" "abc==="))] + [(3) ;; very long + (make-string (+ 100 (random 5000)) #\A)] + [(4) ;; mutated seed + (mutate-string (random-element base64-decode-seeds))] + [(5) ;; pure random + (random-ascii-string (+ 1 (random 200)))])) + +;;; ========== Roundtrip oracle ========== + +(define base64-rt-stats + (fuzz-roundtrip-check "base64" + base64-encode + base64-decode + (lambda () (random-bytevector (random 200))))) + +;;; ========== Decode fuzz ========== + +(define base64-decode-stats + (fuzz-run "base64-decode" + (lambda (input) + (guard (exn [#t (void)]) + (base64-decode input))) + gen-random-base64-decode-input)) + +(when (or (> (fuzz-stats-crashes base64-rt-stats) 0) + (> (fuzz-stats-crashes base64-decode-stats) 0)) + (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/fuzz/harness/fuzz-csv.ss @@ -0,0 +1,72 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; fuzz-csv.ss -- Fuzzer for std/text/csv +;;; +;;; Targets: read-csv, write-csv +;;; Bug classes: unterminated quotes, field explosion, memory + +(import (chezscheme) + (std text csv) + (std test fuzz)) + +;;; ========== Seed corpus ========== + +(define csv-seeds + '("a,b,c\n1,2,3" + "\"quoted\",normal" + "\"has \"\"escaped\"\" quotes\"" + "a,b,c\r\n1,2,3\r\n" + "" + "," + "\n\n\n" + "\"unterminated" + "a,,b,,c" + "\"field with\nnewline\"" + )) + +;;; ========== Generators ========== + +(define (gen-random-csv) + (case (random 8) + [(0) ;; unterminated quote + (string-append "\"" (random-ascii-string 50))] + [(1) ;; many fields per row + (let ([n (+ 10 (random 500))]) + (apply string-append + (map (lambda (i) + (if (zero? i) + (random-ascii-string 5) + (string-append "," (random-ascii-string 5)))) + (iota n))))] + [(2) ;; many rows + (apply string-append + (map (lambda (_) + (string-append (random-ascii-string 10) "," + (random-ascii-string 10) "\n")) + (make-list (+ 10 (random 200)))))] + [(3) ;; long field (approaching limit) + (string-append "\"" (make-string (+ 1000 (random 5000)) #\x) "\"")] + [(4) ;; mixed quotes and commas + (let ([chars (map (lambda (_) + (random-element '(#\, #\" #\newline #\a #\b #\space))) + (make-list (+ 5 (random 100))))]) + (list->string chars))] + [(5) ;; embedded nulls + (string-append "a" (string #\nul) "b,c")] + [(6) ;; mutated seed + (mutate-string (random-element csv-seeds))] + [(7) ;; pure random + (random-ascii-string (+ 1 (random 500)))])) + +;;; ========== Run ========== + +(define csv-stats + (fuzz-run "csv-parse" + (lambda (input) + (guard (exn [#t (void)]) + (let ([port (open-input-string input)]) + (read-csv port)))) + gen-random-csv)) + +(when (> (fuzz-stats-crashes csv-stats) 0) + (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/fuzz/harness/fuzz-dns.ss @@ -0,0 +1,161 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; fuzz-dns.ss -- Fuzzer for std/net/dns +;;; +;;; Targets: dns-decode-response, dns-decode-name +;;; Bug classes: infinite loops (compression), OOB, truncation + +(import (chezscheme) + (std net dns) + (std test fuzz)) + +;;; ========== Seed corpus ========== + +;; Build a minimal valid DNS response: +;; Header (12 bytes): id=0x1234, flags=0x8180, QD=0, AN=1, NS=0, AR=0 +;; Answer: name=\x03www\x07example\x03com\x00, type=A, class=IN, ttl=300, rdlen=4, rdata=93.184.216.34 +(define seed-response + (let ([bv (make-bytevector (+ 12 0 ;; no questions + (+ 17 10 4)) ;; answer: name(17) + type/class/ttl/rdlen(10) + rdata(4) + 0)]) + ;; Header + (bytevector-u8-set! bv 0 #x12) (bytevector-u8-set! bv 1 #x34) ;; ID + (bytevector-u8-set! bv 2 #x81) (bytevector-u8-set! bv 3 #x80) ;; flags: response, no error + ;; QDCOUNT=0 + ;; ANCOUNT=1 + (bytevector-u8-set! bv 7 1) + ;; Answer: www.example.com + (let ([pos 12]) + (bytevector-u8-set! bv pos 3) ;; label "www" + (bytevector-u8-set! bv (+ pos 1) (char->integer #\w)) + (bytevector-u8-set! bv (+ pos 2) (char->integer #\w)) + (bytevector-u8-set! bv (+ pos 3) (char->integer #\w)) + (bytevector-u8-set! bv (+ pos 4) 7) ;; label "example" + (for-each (lambda (c i) + (bytevector-u8-set! bv (+ pos 5 i) (char->integer c))) + (string->list "example") (iota 7)) + (bytevector-u8-set! bv (+ pos 12) 3) ;; label "com" + (for-each (lambda (c i) + (bytevector-u8-set! bv (+ pos 13 i) (char->integer c))) + (string->list "com") (iota 3)) + (bytevector-u8-set! bv (+ pos 16) 0) ;; null terminator + ;; Type A = 1 + (let ([apos (+ pos 17)]) + (bytevector-u8-set! bv (+ apos 1) 1) ;; type=A + (bytevector-u8-set! bv (+ apos 3) 1) ;; class=IN + ;; TTL = 300 + (bytevector-u8-set! bv (+ apos 5) 1) + (bytevector-u8-set! bv (+ apos 6) #x2C) + ;; RDLENGTH = 4 + (bytevector-u8-set! bv (+ apos 9) 4) + ;; RDATA = 93.184.216.34 + (bytevector-u8-set! bv (+ apos 10) 93) + (bytevector-u8-set! bv (+ apos 11) 184) + (bytevector-u8-set! bv (+ apos 12) 216) + (bytevector-u8-set! bv (+ apos 13) 34))) + bv)) + +;;; ========== Generators ========== + +(define (gen-compression-loop) + ;; DNS message with compression pointer to itself + (let ([bv (make-bytevector 14 0)]) + ;; Header: response, 0 questions, 1 answer + (bytevector-u8-set! bv 2 #x80) + (bytevector-u8-set! bv 7 1) + ;; At offset 12: compression pointer to offset 12 (self-loop) + (bytevector-u8-set! bv 12 #xC0) + (bytevector-u8-set! bv 13 12) + bv)) + +(define (gen-compression-cycle) + ;; A -> B -> A cycle + (let ([bv (make-bytevector 16 0)]) + (bytevector-u8-set! bv 2 #x80) + (bytevector-u8-set! bv 7 1) + ;; Offset 12: pointer to 14 + (bytevector-u8-set! bv 12 #xC0) + (bytevector-u8-set! bv 13 14) + ;; Offset 14: pointer to 12 + (bytevector-u8-set! bv 14 #xC0) + (bytevector-u8-set! bv 15 12) + bv)) + +(define (gen-random-dns) + (case (random 10) + [(0) ;; too short for header + (random-bytevector (random 12))] + [(1) ;; compression pointer to self + (gen-compression-loop)] + [(2) ;; compression pointer cycle + (gen-compression-cycle)] + [(3) ;; compression pointer past end + (let ([bv (make-bytevector 14 0)]) + (bytevector-u8-set! bv 2 #x80) + (bytevector-u8-set! bv 7 1) + (bytevector-u8-set! bv 12 #xC0) + (bytevector-u8-set! bv 13 #xFF) ;; points to offset 0x3FFF + bv)] + [(4) ;; QDCOUNT = 65535 but no question data + (let ([bv (make-bytevector 12 0)]) + (bytevector-u8-set! bv 2 #x80) + (bytevector-u8-set! bv 4 #xFF) + (bytevector-u8-set! bv 5 #xFF) + bv)] + [(5) ;; ANCOUNT high but truncated + (let ([bv (make-bytevector 20 0)]) + (bytevector-u8-set! bv 2 #x80) + (bytevector-u8-set! bv 7 10) ;; 10 answers claimed + ;; But only 8 bytes after header + bv)] + [(6) ;; label length 255 + (let ([bv (make-bytevector 14 0)]) + (bytevector-u8-set! bv 2 #x80) + (bytevector-u8-set! bv 7 1) + (bytevector-u8-set! bv 12 255) ;; label len = 255 + bv)] + [(7) ;; all zeros + (make-bytevector 12 0)] + [(8) ;; mutated valid response + (mutate-bytevector seed-response)] + [(9) ;; pure random, at least 12 bytes + (random-bytevector (+ 12 (random (fuzz-max-size))))])) + +;;; ========== Run ========== + +(define dns-stats + (fuzz-run "dns-decode" + (lambda (input) + (guard (exn [#t (void)]) + (dns-decode-response input))) + gen-random-dns)) + +;; Also fuzz dns-decode-name directly +(define dns-name-stats + (fuzz-run "dns-decode-name" + (lambda (input) + (guard (exn [#t (void)]) + (when (>= (bytevector-length input) 1) + (dns-decode-name input 0)))) + (lambda () (random-bytevector (+ 1 (random 256)))) + (quotient (fuzz-iterations) 2))) + +;; Roundtrip: encode-query then decode +(define dns-rt-stats + (fuzz-run "dns-roundtrip" + (lambda (_) + (let* ([name (string-append + (random-ascii-string 10) "." + (random-ascii-string 5) "." + (random-ascii-string 3))] + [query (dns-make-query (random #xFFFF) name dns-rr-type-a)] + [encoded (dns-encode-query query)]) + ;; Just ensure it doesn't crash — can't fully roundtrip queries as responses + (when (>= (bytevector-length encoded) 12) + (void)))) + (lambda () #f) + (quotient (fuzz-iterations) 4))) + +(when (or (> (fuzz-stats-crashes dns-stats) 0) + (> (fuzz-stats-crashes dns-name-stats) 0)) + (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/fuzz/harness/fuzz-format.ss @@ -0,0 +1,95 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; fuzz-format.ss -- Fuzzer for std/format (format string injection) +;;; +;;; Targets: format, printf, safe-printf +;;; Bug classes: format injection, arity mismatch crashes + +(import (chezscheme) + (std format) + (std test fuzz)) + +;;; ========== Seed corpus ========== + +(define format-seeds + '("hello ~a world" + "~s" + "~d" + "~b ~o ~x" + "~%~%~%" + "~~" + "~10a" + "~10,5f" + "no directives" + "" + "~a ~a ~a" + )) + +;;; ========== Generators ========== + +(define (gen-random-format-string) + (case (random 8) + [(0) ;; too many directives, not enough args + (apply string-append + (make-list (+ 2 (random 20)) "~a "))] + [(1) ;; user-controlled input as format string + (random-ascii-string (+ 1 (random 200)))] + [(2) ;; ~* (argument jumping) + "~a ~* ~a"] + [(3) ;; nested ~? (indirect format) + "~?"] + [(4) ;; very long format string + (make-string (+ 100 (random 2000)) #\~)] + [(5) ;; valid format with edge case args + (random-element format-seeds)] + [(6) ;; tilde at end + "hello~"] + [(7) ;; mixed valid and invalid directives + (let ([chars (map (lambda (_) + (if (zero? (random 3)) + #\~ + (integer->char (+ 32 (random 95))))) + (make-list (+ 5 (random 50))))]) + (list->string chars))])) + +(define (gen-format-args) + ;; Generate 0-5 random arguments + (map (lambda (_) + (case (random 4) + [(0) (random 1000)] + [(1) (random-ascii-string 10)] + [(2) #t] + [(3) '(1 2 3)])) + (make-list (random 6)))) + +;;; ========== Run ========== + +;; Fuzz format with random format strings and args +(define format-stats + (fuzz-run "format" + (lambda (_) + (let ([fmt (gen-random-format-string)] + [args (gen-format-args)]) + (guard (exn [#t (void)]) + (let ([port (open-output-string)]) + (apply fprintf port fmt args) + (get-output-string port))))) + (lambda () #f))) + +;; Verify safe-printf doesn't interpret directives +(define safe-stats + (fuzz-run "safe-printf" + (lambda (input) + (guard (exn [#t (void)]) + (let ([port (open-output-string)]) + (safe-fprintf port input) + (let ([result (get-output-string port)]) + ;; safe-fprintf should output the string literally + (unless (string=? result input) + (error 'safe-printf "directive was interpreted!" input result)))))) + (lambda () (gen-random-format-string)) + (quotient (fuzz-iterations) 4))) + +(when (or (> (fuzz-stats-crashes format-stats) 0) + (> (fuzz-stats-crashes safe-stats) 0)) + (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/fuzz/harness/fuzz-hex.ss @@ -0,0 +1,58 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; fuzz-hex.ss -- Fuzzer for std/text/hex +;;; +;;; Targets: hex-encode, hex-decode +;;; Bug classes: odd-length, invalid chars, roundtrip failures + +(import (chezscheme) + (std text hex) + (std test fuzz)) + +;;; ========== Generators ========== + +(define (gen-random-hex-input) + (case (random 6) + [(0) ;; valid hex, even length + (let* ([len (* 2 (+ 1 (random 100)))] + [chars "0123456789abcdef"] + [result (make-string len)]) + (do ([i 0 (+ i 1)]) + ((= i len) result) + (string-set! result i (string-ref chars (random 16)))))] + [(1) ;; odd length + (let* ([len (+ 1 (* 2 (random 50)))] + [chars "0123456789abcdef"] + [result (make-string len)]) + (do ([i 0 (+ i 1)]) + ((= i len) result) + (string-set! result i (string-ref chars (random 16)))))] + [(2) ;; invalid chars + (random-element '("zz" "gg" "0x" "XX" "hello" "0G"))] + [(3) ;; mixed case + (random-element '("aAbBcC" "FF00ff" "DeAdBeEf"))] + [(4) ;; empty + ""] + [(5) ;; pure random + (random-ascii-string (+ 1 (random 200)))])) + +;;; ========== Run ========== + +;; Roundtrip +(define hex-rt-stats + (fuzz-roundtrip-check "hex" + hex-encode + hex-decode + (lambda () (random-bytevector (random 200))))) + +;; Decode fuzz +(define hex-decode-stats + (fuzz-run "hex-decode" + (lambda (input) + (guard (exn [#t (void)]) + (hex-decode input))) + gen-random-hex-input)) + +(when (or (> (fuzz-stats-crashes hex-rt-stats) 0) + (> (fuzz-stats-crashes hex-decode-stats) 0)) + (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/fuzz/harness/fuzz-http2.ss @@ -0,0 +1,131 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; fuzz-http2.ss -- Fuzzer for std/net/http2 +;;; +;;; Targets: http2-frame-decode, hpack-decode +;;; Bug classes: OOB, memory exhaustion, frame confusion + +(import (chezscheme) + (std net http2) + (std test fuzz)) + +;;; ========== Seed corpus: valid frames ==========