Add binary protocol framework with syntax-driven code generation (#17)
ober
af2f93344b9b4cafcc0b496c40814db9b923c58d
new file mode 100644 --- /dev/null +++ b/lib/std/misc/binary-type.sls @@ -0,0 +1,248 @@ +#!chezscheme +;;; (std misc binary-type) — Syntax-driven binary protocol framework +;;; +;;; Define binary types with automatic reader/writer generation. +;;; Supports primitive types, composite records, fixed-length arrays, +;;; and nested structures. +;;; +;;; (define-binary-type uint8 +;;; (reader (lambda (port) (get-u8 port))) +;;; (writer (lambda (port val) (put-u8 port val)))) +;;; +;;; (define-binary-record point +;;; (x uint16-be) +;;; (y uint16-be)) +;;; +;;; (define-binary-array triple-byte uint8 3) + +(library (std misc binary-type) + (export + ;; Core type definition + define-binary-type + ;; Composite records + define-binary-record + ;; Fixed-length arrays + define-binary-array + ;; Generic read/write dispatch + binary-read + binary-write + ;; Type registry + register-binary-type! + ;; Built-in primitive types + uint8 uint16-be uint16-le uint32-be uint32-le + int8 int16-be int16-le int32-be int32-le + float32-be float64-be) + + (import (chezscheme)) + + ;; ========== Type registry ========== + ;; Maps type name (symbol) -> (reader . writer) + + (define *binary-type-registry* (make-hashtable symbol-hash eq?)) + + (define (register-binary-type! name reader writer) + (hashtable-set! *binary-type-registry* name (cons reader writer))) + + (define (lookup-binary-type name) + (let ([entry (hashtable-ref *binary-type-registry* name #f)]) + (unless entry + (error 'lookup-binary-type + (string-append "unknown binary type: " (symbol->string name)))) + entry)) + + ;; ========== Generic read/write ========== + + (define (binary-read type-name port) + (let ([entry (lookup-binary-type type-name)]) + ((car entry) port))) + + (define (binary-write type-name port val) + (let ([entry (lookup-binary-type type-name)]) + ((cdr entry) port val))) + + ;; ========== Helper: read/write via bytevector buffer ========== + + (define (read-bv-value port size ref-proc endian) + (let ([bv (get-bytevector-n port size)]) + (when (or (eof-object? bv) (< (bytevector-length bv) size)) + (error 'binary-read "unexpected end of input")) + (ref-proc bv 0 endian))) + + (define (write-bv-value port val size set-proc! endian) + (let ([bv (make-bytevector size)]) + (set-proc! bv 0 val endian) + (put-bytevector port bv))) + + ;; ========== define-binary-type macro ========== + + (define-syntax define-binary-type + (syntax-rules (reader writer) + [(_ name (reader reader-expr) (writer writer-expr)) + (define name + (let ([r reader-expr] [w writer-expr]) + (register-binary-type! 'name r w) + 'name))])) + + ;; ========== Built-in primitive types ========== + + ;; unsigned integers + (define-binary-type uint8 + (reader (lambda (port) + (let ([b (get-u8 port)]) + (when (eof-object? b) + (error 'binary-read "unexpected end of input")) + b))) + (writer (lambda (port val) + (put-u8 port val)))) + + (define-binary-type uint16-be + (reader (lambda (port) (read-bv-value port 2 bytevector-u16-ref 'big))) + (writer (lambda (port val) (write-bv-value port val 2 bytevector-u16-set! 'big)))) + + (define-binary-type uint16-le + (reader (lambda (port) (read-bv-value port 2 bytevector-u16-ref 'little))) + (writer (lambda (port val) (write-bv-value port val 2 bytevector-u16-set! 'little)))) + + (define-binary-type uint32-be + (reader (lambda (port) (read-bv-value port 4 bytevector-u32-ref 'big))) + (writer (lambda (port val) (write-bv-value port val 4 bytevector-u32-set! 'big)))) + + (define-binary-type uint32-le + (reader (lambda (port) (read-bv-value port 4 bytevector-u32-ref 'little))) + (writer (lambda (port val) (write-bv-value port val 4 bytevector-u32-set! 'little)))) + + ;; signed integers + (define-binary-type int8 + (reader (lambda (port) + (let ([b (get-u8 port)]) + (when (eof-object? b) + (error 'binary-read "unexpected end of input")) + (if (> b 127) (- b 256) b)))) + (writer (lambda (port val) + (put-u8 port (if (< val 0) (+ val 256) val))))) + + (define-binary-type int16-be + (reader (lambda (port) (read-bv-value port 2 bytevector-s16-ref 'big))) + (writer (lambda (port val) (write-bv-value port val 2 bytevector-s16-set! 'big)))) + + (define-binary-type int16-le + (reader (lambda (port) (read-bv-value port 2 bytevector-s16-ref 'little))) + (writer (lambda (port val) (write-bv-value port val 2 bytevector-s16-set! 'little)))) + + (define-binary-type int32-be + (reader (lambda (port) (read-bv-value port 4 bytevector-s32-ref 'big))) + (writer (lambda (port val) (write-bv-value port val 4 bytevector-s32-set! 'big)))) + + (define-binary-type int32-le + (reader (lambda (port) (read-bv-value port 4 bytevector-s32-ref 'little))) + (writer (lambda (port val) (write-bv-value port val 4 bytevector-s32-set! 'little)))) + + ;; floating point + (define-binary-type float32-be + (reader (lambda (port) + (read-bv-value port 4 bytevector-ieee-single-ref 'big))) + (writer (lambda (port val) + (write-bv-value port val 4 bytevector-ieee-single-set! 'big)))) + + (define-binary-type float64-be + (reader (lambda (port) + (read-bv-value port 8 bytevector-ieee-double-ref 'big))) + (writer (lambda (port val) + (write-bv-value port val 8 bytevector-ieee-double-set! 'big)))) + + ;; ========== define-binary-record macro ========== + ;; + ;; (define-binary-record point + ;; (x uint16-be) + ;; (y uint16-be)) + ;; + ;; Generates: + ;; make-point, point-x, point-y, read-point, write-point + ;; Registers 'point in the binary type registry. + + (define-syntax define-binary-record + (lambda (stx) + (syntax-case stx () + [(_ rec-name (field-name field-type) ...) + (with-syntax + ([make-rec (datum->syntax #'rec-name + (string->symbol + (string-append "make-" (symbol->string (syntax->datum #'rec-name)))))] + [read-rec (datum->syntax #'rec-name + (string->symbol + (string-append "read-" (symbol->string (syntax->datum #'rec-name)))))] + [write-rec (datum->syntax #'rec-name + (string->symbol + (string-append "write-" (symbol->string (syntax->datum #'rec-name)))))] + [(accessor ...) + (map (lambda (fn) + (datum->syntax #'rec-name + (string->symbol + (string-append (symbol->string (syntax->datum #'rec-name)) + "-" + (symbol->string (syntax->datum fn)))))) + #'(field-name ...))] + [(idx ...) + (let loop ([i 0] [fields #'(field-name ...)]) + (if (null? fields) '() + (cons (datum->syntax #'rec-name i) + (loop (+ i 1) (cdr fields)))))]) + #'(begin + ;; Record type as a simple vector: #(rec-name field-val ...) + (define (make-rec field-name ...) + (vector 'rec-name field-name ...)) + + (define (accessor rec) (vector-ref rec (+ 1 idx))) ... + + (define (read-rec port) + (let* ([field-name (binary-read 'field-type port)] ...) + (make-rec field-name ...))) + + (define (write-rec port rec) + (binary-write 'field-type port (accessor rec)) ...) + + ;; Register in the type registry + (register-binary-type! 'rec-name read-rec + (lambda (port val) (write-rec port val)))))]))) + + ;; ========== define-binary-array macro ========== + ;; + ;; (define-binary-array triple-byte uint8 3) + ;; + ;; Generates: + ;; read-triple-byte, write-triple-byte + ;; Registers 'triple-byte in the binary type registry. + ;; Values are represented as vectors. + + (define-syntax define-binary-array + (lambda (stx) + (syntax-case stx () + [(_ arr-name elem-type count) + (with-syntax + ([read-arr (datum->syntax #'arr-name + (string->symbol + (string-append "read-" (symbol->string (syntax->datum #'arr-name)))))] + [write-arr (datum->syntax #'arr-name + (string->symbol + (string-append "write-" (symbol->string (syntax->datum #'arr-name)))))]) + #'(begin + (define (read-arr port) + (let ([n count]) + (let ([v (make-vector n)]) + (let loop ([i 0]) + (when (< i n) + (vector-set! v i (binary-read 'elem-type port)) + (loop (+ i 1)))) + v))) + + (define (write-arr port vec) + (let ([n count]) + (let loop ([i 0]) + (when (< i n) + (binary-write 'elem-type port (vector-ref vec i)) + (loop (+ i 1)))))) + + (register-binary-type! 'arr-name read-arr + (lambda (port val) (write-arr port val)))))]))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-binary-type.ss @@ -0,0 +1,294 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc binary-type)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-close actual expected tolerance msg) + (unless (< (abs (- actual expected)) tolerance) + (error 'assert-close + (string-append msg ": expected ~" (format "~s" expected) + " got " (format "~s" actual))))) + +;; Helper: round-trip through a bytevector port +(define (round-trip-bv type-name val) + (let ([bv (call-with-bytevector-output-port + (lambda (out) (binary-write type-name out val)))]) + (let ([in (open-bytevector-input-port bv)]) + (binary-read type-name in)))) + +;; ============ Primitive type tests ============ + +(test "uint8 read/write round-trip" + (lambda () + (assert-equal (round-trip-bv 'uint8 0) 0 "zero") + (assert-equal (round-trip-bv 'uint8 127) 127 "mid") + (assert-equal (round-trip-bv 'uint8 255) 255 "max"))) + +(test "int8 read/write round-trip" + (lambda () + (assert-equal (round-trip-bv 'int8 0) 0 "zero") + (assert-equal (round-trip-bv 'int8 127) 127 "positive max") + (assert-equal (round-trip-bv 'int8 -128) -128 "negative min") + (assert-equal (round-trip-bv 'int8 -1) -1 "negative one"))) + +(test "uint16-be read/write round-trip" + (lambda () + (assert-equal (round-trip-bv 'uint16-be 0) 0 "zero") + (assert-equal (round-trip-bv 'uint16-be 256) 256 "256") + (assert-equal (round-trip-bv 'uint16-be 65535) 65535 "max"))) + +(test "uint16-le read/write round-trip" + (lambda () + (assert-equal (round-trip-bv 'uint16-le 0) 0 "zero") + (assert-equal (round-trip-bv 'uint16-le 256) 256 "256") + (assert-equal (round-trip-bv 'uint16-le 65535) 65535 "max"))) + +(test "uint16 endianness matters" + (lambda () + ;; Write 0x0102 in big-endian: bytes should be 01 02 + (let ([bv (call-with-bytevector-output-port + (lambda (out) (binary-write 'uint16-be out #x0102)))]) + (assert-equal (bytevector-u8-ref bv 0) #x01 "be high byte") + (assert-equal (bytevector-u8-ref bv 1) #x02 "be low byte")) + ;; Write 0x0102 in little-endian: bytes should be 02 01 + (let ([bv (call-with-bytevector-output-port + (lambda (out) (binary-write 'uint16-le out #x0102)))]) + (assert-equal (bytevector-u8-ref bv 0) #x02 "le low byte") + (assert-equal (bytevector-u8-ref bv 1) #x01 "le high byte")))) + +(test "uint32-be round-trip" + (lambda () + (assert-equal (round-trip-bv 'uint32-be 0) 0 "zero") + (assert-equal (round-trip-bv 'uint32-be #xDEADBEEF) #xDEADBEEF "deadbeef"))) + +(test "uint32-le round-trip" + (lambda () + (assert-equal (round-trip-bv 'uint32-le 0) 0 "zero") + (assert-equal (round-trip-bv 'uint32-le #xCAFEBABE) #xCAFEBABE "cafebabe"))) + +(test "int16-be round-trip" + (lambda () + (assert-equal (round-trip-bv 'int16-be 0) 0 "zero") + (assert-equal (round-trip-bv 'int16-be 32767) 32767 "max") + (assert-equal (round-trip-bv 'int16-be -32768) -32768 "min") + (assert-equal (round-trip-bv 'int16-be -1) -1 "neg one"))) + +(test "int16-le round-trip" + (lambda () + (assert-equal (round-trip-bv 'int16-le -1000) -1000 "negative") + (assert-equal (round-trip-bv 'int16-le 1000) 1000 "positive"))) + +(test "int32-be round-trip" + (lambda () + (assert-equal (round-trip-bv 'int32-be 0) 0 "zero") + (assert-equal (round-trip-bv 'int32-be -1) -1 "neg one") + (assert-equal (round-trip-bv 'int32-be 2147483647) 2147483647 "max") + (assert-equal (round-trip-bv 'int32-be -2147483648) -2147483648 "min"))) + +(test "int32-le round-trip" + (lambda () + (assert-equal (round-trip-bv 'int32-le -100000) -100000 "negative") + (assert-equal (round-trip-bv 'int32-le 100000) 100000 "positive"))) + +(test "float32-be round-trip" + (lambda () + (assert-close (round-trip-bv 'float32-be 3.14) 3.14 0.001 "pi") + (assert-equal (round-trip-bv 'float32-be 0.0) 0.0 "zero"))) + +(test "float64-be round-trip" + (lambda () + (assert-close (round-trip-bv 'float64-be 3.141592653589793) 3.141592653589793 1e-15 "pi") + (assert-equal (round-trip-bv 'float64-be 0.0) 0.0 "zero") + (assert-close (round-trip-bv 'float64-be -1.23e10) -1.23e10 1.0 "large neg"))) + +;; ============ Composite record tests ============ + +(define-binary-record point + (x uint16-be) + (y uint16-be)) + +(test "binary-record make and accessors" + (lambda () + (let ([p (make-point 100 200)]) + (assert-equal (point-x p) 100 "x") + (assert-equal (point-y p) 200 "y")))) + +(test "binary-record read/write round-trip" + (lambda () + (let* ([p (make-point 300 400)] + [bv (call-with-bytevector-output-port + (lambda (out) (write-point out p)))] + [in (open-bytevector-input-port bv)] + [p2 (read-point in)]) + (assert-equal (point-x p2) 300 "x") + (assert-equal (point-y p2) 400 "y")))) + +(test "binary-record via generic binary-read/write" + (lambda () + (let* ([p (make-point 500 600)] + [bv (call-with-bytevector-output-port + (lambda (out) (binary-write 'point out p)))] + [in (open-bytevector-input-port bv)] + [p2 (binary-read 'point in)]) + (assert-equal (point-x p2) 500 "x") + (assert-equal (point-y p2) 600 "y")))) + +(test "binary-record byte layout" + (lambda () + ;; point is two uint16-be fields: 4 bytes total + (let ([bv (call-with-bytevector-output-port + (lambda (out) (write-point out (make-point #x0102 #x0304))))]) + (assert-equal (bytevector-length bv) 4 "size") + (assert-equal (bytevector-u8-ref bv 0) #x01 "x high") + (assert-equal (bytevector-u8-ref bv 1) #x02 "x low") + (assert-equal (bytevector-u8-ref bv 2) #x03 "y high") + (assert-equal (bytevector-u8-ref bv 3) #x04 "y low")))) + +;; Record with mixed types +(define-binary-record header + (magic uint32-be) + (version uint8) + (flags uint16-le)) + +(test "binary-record with mixed types" + (lambda () + (let* ([h (make-header #xDEADBEEF 2 #x0100)] + [bv (call-with-bytevector-output-port + (lambda (out) (write-header out h)))] + [in (open-bytevector-input-port bv)] + [h2 (read-header in)]) + (assert-equal (header-magic h2) #xDEADBEEF "magic") + (assert-equal (header-version h2) 2 "version") + (assert-equal (header-flags h2) #x0100 "flags")))) + +;; ============ Nested record tests ============ + +(define-binary-record rect + (top-left point) + (bottom-right point)) + +(test "nested record round-trip" + (lambda () + (let* ([r (make-rect (make-point 10 20) (make-point 30 40))] + [bv (call-with-bytevector-output-port + (lambda (out) (write-rect out r)))] + [in (open-bytevector-input-port bv)] + [r2 (read-rect in)]) + (assert-equal (point-x (rect-top-left r2)) 10 "tl-x") + (assert-equal (point-y (rect-top-left r2)) 20 "tl-y") + (assert-equal (point-x (rect-bottom-right r2)) 30 "br-x") + (assert-equal (point-y (rect-bottom-right r2)) 40 "br-y")))) + +(test "nested record byte size" + (lambda () + ;; rect = 2 points = 4 uint16-be = 8 bytes + (let ([bv (call-with-bytevector-output-port + (lambda (out) (write-rect out + (make-rect (make-point 1 2) (make-point 3 4)))))]) + (assert-equal (bytevector-length bv) 8 "size")))) + +;; ============ Array tests ============ + +(define-binary-array byte-triple uint8 3) + +(test "binary-array read/write round-trip" + (lambda () + (let* ([arr (vector 10 20 30)] + [bv (call-with-bytevector-output-port + (lambda (out) (write-byte-triple out arr)))] + [in (open-bytevector-input-port bv)] + [arr2 (read-byte-triple in)]) + (assert-equal arr2 (vector 10 20 30) "values")))) + +(define-binary-array point-array point 2) + +(test "array of records round-trip" + (lambda () + (let* ([arr (vector (make-point 100 200) (make-point 300 400))] + [bv (call-with-bytevector-output-port + (lambda (out) (write-point-array out arr)))] + [in (open-bytevector-input-port bv)] + [arr2 (read-point-array in)]) + (assert-equal (point-x (vector-ref arr2 0)) 100 "p0-x") + (assert-equal (point-y (vector-ref arr2 0)) 200 "p0-y") + (assert-equal (point-x (vector-ref arr2 1)) 300 "p1-x") + (assert-equal (point-y (vector-ref arr2 1)) 400 "p1-y")))) + +(test "binary-array via generic dispatch" + (lambda () + (let* ([arr (vector 1 2 3)] + [bv (call-with-bytevector-output-port + (lambda (out) (binary-write 'byte-triple out arr)))] + [in (open-bytevector-input-port bv)] + [arr2 (binary-read 'byte-triple in)]) + (assert-equal arr2 (vector 1 2 3) "values")))) + +(define-binary-array u32-pair uint32-be 2) + +(test "array of uint32-be round-trip" + (lambda () + (let* ([arr (vector #xAABBCCDD #x11223344)] + [bv (call-with-bytevector-output-port + (lambda (out) (write-u32-pair out arr)))] + [in (open-bytevector-input-port bv)] + [arr2 (read-u32-pair in)]) + (assert-equal (vector-ref arr2 0) #xAABBCCDD "first") + (assert-equal (vector-ref arr2 1) #x11223344 "second")))) + +;; ============ Multiple values sequentially ============ + +(test "read/write multiple values sequentially" + (lambda () + (let ([bv (call-with-bytevector-output-port + (lambda (out) + (binary-write 'uint8 out 42) + (binary-write 'uint32-be out #xCAFEBABE) + (binary-write 'int16-be out -1000)))]) + (let ([in (open-bytevector-input-port bv)]) + (assert-equal (binary-read 'uint8 in) 42 "byte") + (assert-equal (binary-read 'uint32-be in) #xCAFEBABE "u32") + (assert-equal (binary-read 'int16-be in) -1000 "i16"))))) + +;; ============ Custom type test ============ + +(test "define-binary-type custom type" + (lambda () + (define-binary-type bool8 + (reader (lambda (port) + (let ([b (get-u8 port)]) + (not (zero? b))))) + (writer (lambda (port val) + (put-u8 port (if val 1 0))))) + (let ([bv (call-with-bytevector-output-port + (lambda (out) + (binary-write 'bool8 out #t) + (binary-write 'bool8 out #f)))]) + (let ([in (open-bytevector-input-port bv)]) + (assert-equal (binary-read 'bool8 in) #t "true") + (assert-equal (binary-read 'bool8 in) #f "false"))))) + +;; ============ Results ============ + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))