857 lines
34 KiB
Racket
857 lines
34 KiB
Racket
#lang racket/base
|
|
;; Preserve, as in Fruit Preserve, as in a remarkably weak pun on pickling/dehydration etc
|
|
|
|
(provide (struct-out stream-of)
|
|
(struct-out record)
|
|
short-form-labels
|
|
read-preserve
|
|
string->preserve
|
|
encode
|
|
decode
|
|
wire-value)
|
|
|
|
(require racket/bytes)
|
|
(require racket/dict)
|
|
(require racket/generator)
|
|
(require racket/match)
|
|
(require racket/set)
|
|
(require bitsyntax)
|
|
(require syndicate/support/struct)
|
|
(require (only-in syntax/readerr raise-read-error))
|
|
|
|
(require imperative-syndicate/assertions)
|
|
(require imperative-syndicate/pattern)
|
|
|
|
(struct stream-of (kind generator) #:transparent)
|
|
|
|
(struct record (label fields) #:transparent)
|
|
|
|
(define short-form-labels
|
|
(make-parameter (vector 'discard 'capture 'observe)))
|
|
|
|
(define (encode v)
|
|
(bit-string->bytes (bit-string (v :: (wire-value)))))
|
|
|
|
(define (decode bs [on-fail (lambda () (error 'decode "Invalid encoding: ~v" bs))])
|
|
(bit-string-case bs
|
|
([ (v :: (wire-value)) ] v)
|
|
(else (on-fail))))
|
|
|
|
(define-syntax wire-value
|
|
(syntax-rules ()
|
|
[(_ #t input ks kf) (decode-value input ks kf)]
|
|
[(_ #f v) (encode-value v)]))
|
|
|
|
(define-syntax wire-length
|
|
(syntax-rules ()
|
|
[(_ #t input ks kf) (decode-wire-length input ks kf)]
|
|
[(_ #f v) (encode-wire-length v)]))
|
|
|
|
(define (encode-wire-length v)
|
|
(when (negative? v) (error 'encode-wire-length "Cannot encode negative wire-length ~v" v))
|
|
(if (< v #b1111)
|
|
(bit-string (v :: bits 4))
|
|
(bit-string (#b1111 :: bits 4) ((encode-varint v) :: binary))))
|
|
|
|
(define (encode-varint v)
|
|
(if (< v 128)
|
|
(bytes v)
|
|
(bit-string ((+ (modulo v 128) 128) :: bits 8)
|
|
((encode-varint (quotient v 128)) :: binary))))
|
|
|
|
(define (encode-array-like major minor fields)
|
|
(bit-string (major :: bits 2)
|
|
(minor :: bits 2)
|
|
((length fields) :: (wire-length))
|
|
((apply bit-string-append (map encode-value fields)) :: binary)))
|
|
|
|
(define (encode-binary-like major minor bs)
|
|
(bit-string (major :: bits 2)
|
|
(minor :: bits 2)
|
|
((bytes-length bs) :: (wire-length))
|
|
(bs :: binary)))
|
|
|
|
(define (encode-start-byte major minor)
|
|
(bit-string (#b0010 :: bits 4) (major :: bits 2) (minor :: bits 2)))
|
|
|
|
(define (encode-end-byte major minor)
|
|
(bit-string (#b0011 :: bits 4) (major :: bits 2) (minor :: bits 2)))
|
|
|
|
(define (encode-stream major minor chunk-ok? generator)
|
|
(bit-string-append (encode-start-byte major minor)
|
|
(let loop ()
|
|
(match (generator)
|
|
[(? void?) #""]
|
|
[(? chunk-ok? v) (bit-string-append (encode-value v) (loop))]
|
|
[bad (error 'encode-stream "Cannot encode chunk: ~v" bad)]))
|
|
(encode-end-byte major minor)))
|
|
|
|
(define (dict-keys-and-values d)
|
|
(reverse (for/fold [(acc '())] [((k v) (in-dict d))] (cons v (cons k acc)))))
|
|
|
|
(define (short-form-for-label key)
|
|
(let ((labels (short-form-labels)))
|
|
(let loop ((i 0))
|
|
(cond [(= i 3) #f]
|
|
[(equal? (vector-ref labels i) key) i]
|
|
[else (loop (+ i 1))]))))
|
|
|
|
(define (encode-record key fields)
|
|
(define short (short-form-for-label key))
|
|
(if short
|
|
(encode-array-like 2 short fields)
|
|
(encode-array-like 2 3 (cons key fields))))
|
|
|
|
(define (encode-value v)
|
|
(match v
|
|
[#f (bytes #b00000000)]
|
|
[#t (bytes #b00000001)]
|
|
[(? single-flonum?) (bit-string #b00000010 (v :: float bits 32))]
|
|
[(? double-flonum?) (bit-string #b00000011 (v :: float bits 64))]
|
|
[(? integer? x) #:when (<= -3 x 12) (bit-string (#b0001 :: bits 4) (x :: bits 4))]
|
|
[(stream-of 'string p) (encode-stream 1 1 bytes? p)]
|
|
[(stream-of 'byte-string p) (encode-stream 1 2 bytes? p)]
|
|
[(stream-of 'symbol p) (encode-stream 1 3 bytes? p)]
|
|
[(stream-of 'sequence p) (encode-stream 3 0 (lambda (x) #t) p)]
|
|
[(stream-of 'set p) (encode-stream 3 1 (lambda (x) #t) p)]
|
|
[(stream-of 'dictionary p) (encode-stream 3 2 (lambda (x) #t) p)]
|
|
|
|
;; [0 (bytes #b10000000)]
|
|
[(? integer?)
|
|
(define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
|
|
(define byte-count (quotient (+ raw-bit-count 7) 8))
|
|
(bit-string (#b0100 :: bits 4) (byte-count :: (wire-length)) (v :: integer bytes byte-count))]
|
|
[(? string?) (encode-binary-like 1 1 (string->bytes/utf-8 v))]
|
|
[(? bytes?) (encode-binary-like 1 2 v)]
|
|
[(? symbol?) (encode-binary-like 1 3 (string->bytes/utf-8 (symbol->string v)))]
|
|
|
|
[(record label fields) (encode-record label fields)]
|
|
[(? non-object-struct?)
|
|
(define key (prefab-struct-key v))
|
|
(when (not key) (error 'encode-value "Cannot encode non-prefab struct ~v" v))
|
|
(encode-record key (cdr (vector->list (struct->vector v))))]
|
|
|
|
[(? list?) (encode-array-like 3 0 v)]
|
|
[(? set?) (encode-array-like 3 1 (set->list v))]
|
|
[(? dict?) (encode-array-like 3 2 (dict-keys-and-values v))]
|
|
|
|
[_ (error 'encode-value "Cannot encode value ~v" v)]))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define (decode-wire-length bs ks kf)
|
|
(bit-string-case bs
|
|
([ (= #b1111 :: bits 4) (rest :: binary) ]
|
|
(decode-varint rest
|
|
(lambda (v tail)
|
|
(if (< v #b1111)
|
|
(kf)
|
|
(ks v tail)))
|
|
kf))
|
|
([ (v :: bits 4) (rest :: binary) ] (ks v rest))
|
|
(else (kf))))
|
|
|
|
(define (decode-varint bs ks kf)
|
|
(bit-string-case bs
|
|
([ (= 1 :: bits 1) (v :: bits 7) (rest :: binary) ]
|
|
(decode-varint rest (lambda (acc tail) (ks (+ (* acc 128) v) tail)) kf))
|
|
([ (= 0 :: bits 1) (v :: bits 7) (rest :: binary) ]
|
|
(ks v rest))
|
|
(else
|
|
(kf))))
|
|
|
|
(define (decode-values n acc-rev bs ks kf)
|
|
(if (zero? n)
|
|
(ks (reverse acc-rev) bs)
|
|
(bit-string-case bs
|
|
([ (v :: (wire-value)) (rest :: binary) ]
|
|
(decode-values (- n 1) (cons v acc-rev) rest ks kf))
|
|
(else (kf)))))
|
|
|
|
(define (decode-binary minor bs rest ks kf)
|
|
(match minor
|
|
[0 (if (positive? (bit-string-length bs))
|
|
(ks (bit-string->signed-integer bs #t) rest)
|
|
(ks 0 rest))]
|
|
[2 (ks bs rest)]
|
|
[(or 1 3)
|
|
((with-handlers [(exn:fail:contract? (lambda (e) kf))]
|
|
(define s (bytes->string/utf-8 bs))
|
|
(lambda () (ks (if (= minor 3) (string->symbol s) s) rest))))]))
|
|
|
|
(define (build-record label fields)
|
|
(with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
|
|
(apply make-prefab-struct label fields)))
|
|
|
|
(define (decode-record minor fields rest ks kf)
|
|
(match* (minor fields)
|
|
[(3 (list* key fs)) (ks (build-record key fs) rest)]
|
|
[(3 '()) (kf)]
|
|
[(n fs) (ks (build-record (vector-ref (short-form-labels) n) fs) rest)]))
|
|
|
|
(define (decode-collection minor vs rest ks kf)
|
|
(match minor
|
|
[0 (ks vs rest)]
|
|
[1 (ks (list->set vs) rest)]
|
|
[2 (if (even? (length vs))
|
|
(ks (apply hash vs) rest)
|
|
(kf))]
|
|
[_ (kf)]))
|
|
|
|
(define (decode-stream major minor chunk-ok? join-chunks decode rest ks kf)
|
|
(let loop ((acc-rev '()) (rest rest))
|
|
(bit-string-case rest
|
|
([ (= #b0011 :: bits 4) (emajor :: bits 2) (eminor :: bits 2) (rest :: binary) ]
|
|
(if (and (= major emajor) (= minor eminor))
|
|
(decode minor (join-chunks (reverse acc-rev)) rest ks kf)
|
|
(kf)))
|
|
(else
|
|
(decode-value rest
|
|
(lambda (chunk rest)
|
|
(if (chunk-ok? chunk)
|
|
(loop (cons chunk acc-rev) rest)
|
|
(kf)))
|
|
kf)))))
|
|
|
|
(define (decode-value bs ks kf)
|
|
(bit-string-case bs
|
|
([ (= #b00000000 :: bits 8) (rest :: binary) ] (ks #f rest))
|
|
([ (= #b00000001 :: bits 8) (rest :: binary) ] (ks #t rest))
|
|
([ (= #b00000010 :: bits 8) (v :: float bits 32) (rest :: binary) ] (ks (real->single-flonum v) rest))
|
|
([ (= #b00000011 :: bits 8) (v :: float bits 64) (rest :: binary) ] (ks v rest))
|
|
([ (= #b0001 :: bits 4) (x :: bits 4) (rest :: binary) ] (ks (if (> x 12) (- x 16) x) rest))
|
|
|
|
([ (= #b001001 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
|
(decode-stream 1 minor bytes? bytes-append* decode-binary rest ks kf))
|
|
([ (= #b001010 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
|
(decode-stream 2 minor (lambda (x) #t) values decode-record rest ks kf))
|
|
([ (= #b001011 :: bits 6) (minor :: bits 2) (rest :: binary) ]
|
|
(decode-stream 3 minor (lambda (x) #t) values decode-collection rest ks kf))
|
|
|
|
([ (= #b01 :: bits 2) (minor :: bits 2) (byte-count :: (wire-length))
|
|
(bits :: binary bytes byte-count)
|
|
(rest :: binary) ]
|
|
(decode-binary minor (bit-string->bytes bits) rest ks kf))
|
|
|
|
([ (= #b10 :: bits 2) (minor :: bits 2) (field-count :: (wire-length)) (rest :: binary) ]
|
|
(decode-values field-count '() rest
|
|
(lambda (fields rest) (decode-record minor fields rest ks kf))
|
|
kf))
|
|
|
|
([ (= #b11 :: bits 2) (minor :: bits 2) (count :: (wire-length)) (rest :: binary) ]
|
|
(decode-values count '() rest
|
|
(lambda (vs rest) (decode-collection minor vs rest ks kf))
|
|
kf))
|
|
|
|
(else (kf))))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define (skip-whitespace* i)
|
|
(regexp-match? #px#"^(\\s|,)*" i)
|
|
(match (peek-char i)
|
|
[#\; (regexp-match? #px#"[^\r\n]*[\r\n]" i) (skip-whitespace* i)]
|
|
[_ #t]))
|
|
|
|
(define (parse-error* i fmt . args)
|
|
(define-values [line column pos] (port-next-location i))
|
|
(raise-read-error (format "read-preserve: ~a" (apply format fmt args))
|
|
(object-name i)
|
|
line
|
|
column
|
|
pos
|
|
#f))
|
|
|
|
(define (read-preserve [i (current-input-port)])
|
|
(local-require net/base64)
|
|
(local-require file/sha1)
|
|
|
|
(define-match-expander px
|
|
(syntax-rules ()
|
|
[(_ re pat) (app (lambda (v) (regexp-try-match re v)) pat)]))
|
|
|
|
(define (parse-error fmt . args)
|
|
(apply parse-error* i fmt args))
|
|
|
|
(define (eof-guard ch)
|
|
(match ch
|
|
[(? eof-object?) (parse-error "Unexpected end of input")]
|
|
[ch ch]))
|
|
|
|
(define (peek/no-eof) (eof-guard (peek-char i)))
|
|
(define (read/no-eof) (eof-guard (read-char i)))
|
|
|
|
(define (skip-whitespace) (skip-whitespace* i))
|
|
|
|
(define (read-sequence terminator)
|
|
(sequence-fold '() (lambda (acc) (cons (read-value) acc)) reverse terminator))
|
|
|
|
(define (read-dictionary-or-set)
|
|
(sequence-fold #f
|
|
(lambda (acc)
|
|
(define k (read-value))
|
|
(skip-whitespace)
|
|
(match (peek-char i)
|
|
[#\: (when (set? acc) (parse-error "Unexpected key/value separator in set"))
|
|
(read-char i)
|
|
(define v (read-value))
|
|
(hash-set (or acc (hash)) k v)]
|
|
[_ (when (hash? acc) (parse-error "Missing expected key/value separator"))
|
|
(set-add (or acc (set)) k)]))
|
|
(lambda (acc) (or acc (hash)))
|
|
#\}))
|
|
|
|
(define PIPE #\|)
|
|
|
|
(define (read-raw-symbol acc)
|
|
(match (peek-char i)
|
|
[(or (? eof-object?)
|
|
(? char? (or #\( #\) #\{ #\} #\[ #\]
|
|
#\" #\; #\, #\# #\: (== PIPE)
|
|
(? char-whitespace?))))
|
|
(string->symbol (list->string (reverse acc)))]
|
|
[_ (read-raw-symbol (cons (read-char i) acc))]))
|
|
|
|
(define (read-base64-binary acc)
|
|
(skip-whitespace)
|
|
(define ch (read/no-eof))
|
|
(cond [(eqv? ch #\})
|
|
(base64-decode (string->bytes/latin-1 (list->string (reverse acc))))]
|
|
[(or (and (char>=? ch #\A) (char<=? ch #\Z))
|
|
(and (char>=? ch #\a) (char<=? ch #\z))
|
|
(and (char>=? ch #\0) (char<=? ch #\9))
|
|
(memv ch '(#\+ #\/ #\- #\_ #\=)))
|
|
(read-base64-binary (cons ch acc))]
|
|
[else
|
|
(parse-error "Invalid base64 character")]))
|
|
|
|
(define (hexdigit? ch)
|
|
(or (and (char>=? ch #\A) (char<=? ch #\F))
|
|
(and (char>=? ch #\a) (char<=? ch #\f))
|
|
(and (char>=? ch #\0) (char<=? ch #\9))))
|
|
|
|
(define (read-hex-binary acc)
|
|
(skip-whitespace)
|
|
(define ch (read/no-eof))
|
|
(cond [(eqv? ch #\})
|
|
(hex-string->bytes (list->string (reverse acc)))]
|
|
[(hexdigit? ch)
|
|
(define ch2 (read/no-eof))
|
|
(when (not (hexdigit? ch2))
|
|
(parse-error "Hex-encoded binary digits must come in pairs"))
|
|
(read-hex-binary (cons ch2 (cons ch acc)))]
|
|
[else
|
|
(parse-error "Invalid hex character")]))
|
|
|
|
(define (read-stringlike xform-item finish terminator-char hexescape-char hexescape-proc)
|
|
(let loop ((acc '()))
|
|
(match (read/no-eof)
|
|
[(== terminator-char) (finish (reverse acc))]
|
|
[#\\ (match (read/no-eof)
|
|
[(== hexescape-char) (loop (cons (hexescape-proc) acc))]
|
|
[(and c (or (== terminator-char) #\\ #\/)) (loop (cons (xform-item c) acc))]
|
|
[#\b (loop (cons (xform-item #\u08) acc))]
|
|
[#\f (loop (cons (xform-item #\u0C) acc))]
|
|
[#\n (loop (cons (xform-item #\u0A) acc))]
|
|
[#\r (loop (cons (xform-item #\u0D) acc))]
|
|
[#\t (loop (cons (xform-item #\u09) acc))]
|
|
[c (parse-error "Invalid escape code \\~a" c)])]
|
|
[c (loop (cons (xform-item c) acc))])))
|
|
|
|
(define (read-string terminator-char)
|
|
(read-stringlike values
|
|
list->string
|
|
terminator-char
|
|
#\u
|
|
(lambda ()
|
|
(integer->char
|
|
(match i
|
|
[(px #px#"^[a-fA-F0-9]{4}" (list hexdigits))
|
|
(define n1 (string->number (bytes->string/utf-8 hexdigits) 16))
|
|
(if (<= #xd800 n1 #xdfff) ;; surrogate pair first half
|
|
(match i
|
|
[(px #px#"^\\\\u([a-fA-F0-9]{4})" (list _ hexdigits2))
|
|
(define n2 (string->number (bytes->string/utf-8 hexdigits2) 16))
|
|
(if (<= #xdc00 n2 #xdfff)
|
|
(+ (arithmetic-shift (- n1 #xd800) 10)
|
|
(- n2 #xdc00)
|
|
#x10000)
|
|
(parse-error "Bad second half of surrogate pair"))]
|
|
[_ (parse-error "Missing second half of surrogate pair")])
|
|
n1)]
|
|
[_ (parse-error "Bad string \\u escape")])))))
|
|
|
|
(define (read-literal-binary)
|
|
(read-stringlike (lambda (c)
|
|
(define b (char->integer c))
|
|
(when (>= b 256)
|
|
(parse-error "Invalid code point ~a (~v) in literal binary" b c))
|
|
b)
|
|
list->bytes
|
|
#\"
|
|
#\x
|
|
(lambda ()
|
|
(match i
|
|
[(px #px#"^[a-fA-F0-9]{2}" (list hexdigits))
|
|
(string->number (bytes->string/utf-8 hexdigits) 16)]
|
|
[_ (parse-error "Bad binary \\x escape")]))))
|
|
|
|
(define (read-intpart acc-rev)
|
|
(match (peek-char i)
|
|
[#\0 (read-fracexp (cons (read-char i) acc-rev))]
|
|
[_ (read-digit+ acc-rev read-fracexp)]))
|
|
|
|
(define (read-digit* acc-rev k)
|
|
(match (peek-char i)
|
|
[(? char? (? char-numeric?)) (read-digit* (cons (read-char i) acc-rev) k)]
|
|
[_ (k acc-rev)]))
|
|
|
|
(define (read-digit+ acc-rev k)
|
|
(match (peek-char i)
|
|
[(? char? (? char-numeric?)) (read-digit* (cons (read-char i) acc-rev) k)]
|
|
[_ (parse-error "Incomplete number")]))
|
|
|
|
(define (read-fracexp acc-rev)
|
|
(match (peek-char i)
|
|
[#\. (read-digit+ (cons (read-char i) acc-rev) read-exp)]
|
|
[_ (read-exp acc-rev)]))
|
|
|
|
(define (read-exp acc-rev)
|
|
(match (peek-char i)
|
|
[(or #\e #\E) (read-sign-and-exp (cons (read-char i) acc-rev))]
|
|
[_ (finish-number acc-rev)]))
|
|
|
|
(define (read-sign-and-exp acc-rev)
|
|
(match (peek-char i)
|
|
[(or #\+ #\-) (read-digit+ (cons (read-char i) acc-rev) finish-number)]
|
|
[_ (read-digit+ acc-rev finish-number)]))
|
|
|
|
(define (finish-number acc-rev)
|
|
(define s (list->string (reverse acc-rev)))
|
|
(define n (string->number s))
|
|
(when (not n) (parse-error "Invalid number: ~v" s))
|
|
(if (flonum? n)
|
|
(match (peek-char i)
|
|
[(or #\f #\F) (read-char i) (real->single-flonum n)]
|
|
[_ n])
|
|
n))
|
|
|
|
(define (read-number)
|
|
(match (peek/no-eof)
|
|
[#\- (read-intpart (list (read-char i)))]
|
|
[_ (read-intpart (list))]))
|
|
|
|
(define (sequence-fold acc accumulate-one finish terminator-char)
|
|
(let loop ((acc acc))
|
|
(skip-whitespace)
|
|
(match (peek/no-eof)
|
|
[(== terminator-char) (read-char i) (finish acc)]
|
|
[_ (loop (accumulate-one acc))])))
|
|
|
|
(define (collect-fields head)
|
|
(match (peek-char i)
|
|
[#\(
|
|
(read-char i)
|
|
(collect-fields (build-record head (read-sequence #\))))]
|
|
[_
|
|
head]))
|
|
|
|
(define (read-value)
|
|
(skip-whitespace)
|
|
(collect-fields
|
|
(match (peek-char i)
|
|
[(? eof-object? o) o]
|
|
[#\{ (read-char i) (read-dictionary-or-set)]
|
|
[#\[ (read-char i) (read-sequence #\])]
|
|
[(or #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read-number)]
|
|
[#\" (read-char i) (read-string #\")]
|
|
[(== PIPE) (read-char i) (string->symbol (read-string PIPE))]
|
|
[#\# (match i
|
|
[(px #px#"^#set\\{" (list _))
|
|
(sequence-fold (set) (lambda (acc) (set-add acc (read-value))) values #\})]
|
|
[(px #px#"^#hexvalue\\{" (list _))
|
|
(decode (read-hex-binary '()) (lambda () (parse-error "Invalid #hexvalue encoding")))]
|
|
[(px #px#"^#true" (list _))
|
|
#t]
|
|
[(px #px#"^#false" (list _))
|
|
#f]
|
|
[(px #px#"^#\"" (list _))
|
|
(read-literal-binary)]
|
|
[(px #px#"^#hex\\{" (list _))
|
|
(read-hex-binary '())]
|
|
[(px #px#"^#base64\\{" (list _))
|
|
(read-base64-binary '())]
|
|
[_
|
|
(parse-error "Invalid preserve value")])]
|
|
[#\: (parse-error "Unexpected key/value separator between items")]
|
|
[_ (read-raw-symbol '())])))
|
|
|
|
(read-value))
|
|
|
|
(define (string->preserve s)
|
|
(define p (open-input-string s))
|
|
(define v (read-preserve p))
|
|
(skip-whitespace* p)
|
|
(when (not (eof-object? (peek-char p)))
|
|
(parse-error* p "Unexpected text following preserve"))
|
|
v)
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
(require (for-syntax racket syntax/srcloc))
|
|
|
|
(check-equal? (bit-string->bytes (encode-varint 0)) (bytes 0))
|
|
(check-equal? (bit-string->bytes (encode-varint 1)) (bytes 1))
|
|
(check-equal? (bit-string->bytes (encode-varint 127)) (bytes 127))
|
|
(check-equal? (bit-string->bytes (encode-varint 128)) (bytes 128 1))
|
|
(check-equal? (bit-string->bytes (encode-varint 255)) (bytes 255 1))
|
|
(check-equal? (bit-string->bytes (encode-varint 256)) (bytes 128 2))
|
|
(check-equal? (bit-string->bytes (encode-varint 300)) (bytes #b10101100 #b00000010))
|
|
(check-equal? (bit-string->bytes (encode-varint 1000000000)) (bytes 128 148 235 220 3))
|
|
|
|
(define (ks* v rest) (list v (bit-string->bytes rest)))
|
|
(define (kf*) (void))
|
|
|
|
(check-equal? (decode-varint (bytes 0) ks* kf*) (list 0 (bytes)))
|
|
(check-equal? (decode-varint (bytes 0 99) ks* kf*) (list 0 (bytes 99)))
|
|
(check-equal? (decode-varint (bytes 1) ks* kf*) (list 1 (bytes)))
|
|
(check-equal? (decode-varint (bytes 127) ks* kf*) (list 127 (bytes)))
|
|
(check-equal? (decode-varint (bytes 128 1) ks* kf*) (list 128 (bytes)))
|
|
(check-equal? (decode-varint (bytes 128 1 99) ks* kf*) (list 128 (bytes 99)))
|
|
(check-equal? (decode-varint (bytes 255 1) ks* kf*) (list 255 (bytes)))
|
|
(check-equal? (decode-varint (bytes 128 2) ks* kf*) (list 256 (bytes)))
|
|
(check-equal? (decode-varint (bytes #b10101100 #b00000010) ks* kf*) (list 300 (bytes)))
|
|
(check-equal? (decode-varint (bytes 128 148 235 220 3) ks* kf*) (list 1000000000 (bytes)))
|
|
(check-equal? (decode-varint (bytes 128 148 235 220 3 99) ks* kf*) (list 1000000000 (bytes 99)))
|
|
|
|
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (0 :: (wire-length)))) (bytes 0))
|
|
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (3 :: (wire-length)))) (bytes 3))
|
|
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (14 :: (wire-length)))) (bytes 14))
|
|
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (15 :: (wire-length)))) (bytes 15 15))
|
|
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (100 :: (wire-length))))
|
|
(bytes 15 100))
|
|
(check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (300 :: (wire-length))))
|
|
(bytes 15 #b10101100 #b00000010))
|
|
|
|
(define (dwl bs)
|
|
(bit-string-case bs
|
|
([ (= 0 :: bits 4) (w :: (wire-length)) ] w)
|
|
(else (void))))
|
|
|
|
(check-equal? (dwl (bytes 0)) 0)
|
|
(check-equal? (dwl (bytes 3)) 3)
|
|
(check-equal? (dwl (bytes 14)) 14)
|
|
(check-equal? (dwl (bytes 15)) (void))
|
|
(check-equal? (dwl (bytes 15 9)) (void)) ;; not canonical
|
|
(check-equal? (dwl (bytes 15 15)) 15)
|
|
(check-equal? (dwl (bytes 15 100)) 100)
|
|
(check-equal? (dwl (bytes 15 #b10101100 #b00000010)) 300)
|
|
|
|
(struct speak (who what) #:prefab)
|
|
|
|
(define (expected . pieces)
|
|
(bit-string->bytes
|
|
(apply bit-string-append
|
|
(map (match-lambda
|
|
[(? byte? b) (bytes b)]
|
|
[(? bytes? bs) bs]
|
|
[(? string? s) (string->bytes/utf-8 s)])
|
|
pieces))))
|
|
|
|
(define (d bs) (decode bs void))
|
|
|
|
(define-syntax (cross-check stx)
|
|
(syntax-case stx ()
|
|
((_ text v (b ...))
|
|
#'(let ((val v)) (cross-check text v v (b ...))))
|
|
((_ text forward back (b ...))
|
|
#`(let ((loc #,(source-location->string #'forward)))
|
|
(check-equal? (string->preserve text) back loc)
|
|
(check-equal? (d (encode forward)) back loc)
|
|
(check-equal? (d (encode back)) back loc)
|
|
(check-equal? (d (expected b ...)) back loc)
|
|
(check-equal? (encode forward) (expected b ...) loc)
|
|
))))
|
|
|
|
(define-syntax (cross-check/nondeterministic stx)
|
|
(syntax-case stx ()
|
|
((_ text v (b ...))
|
|
#'(let ((val v)) (cross-check/nondeterministic text v v (b ...))))
|
|
((_ text forward back (b ...))
|
|
#`(let ((loc #,(source-location->string #'forward)))
|
|
(check-equal? (string->preserve text) back loc)
|
|
(check-equal? (d (encode forward)) back loc)
|
|
(check-equal? (d (encode back)) back loc)
|
|
(check-equal? (d (expected b ...)) back loc)
|
|
))))
|
|
|
|
(cross-check "capture(discard())" (capture (discard)) (#x91 #x80))
|
|
(cross-check "observe(speak(discard(), capture(discard())))"
|
|
(observe (speak (discard) (capture (discard))))
|
|
(#xA1 #xB3 #x75 "speak" #x80 #x91 #x80))
|
|
(cross-check "[1, 2, 3, 4]" '(1 2 3 4) (#xC4 #x11 #x12 #x13 #x14))
|
|
(cross-check "[1 2 3 4]"
|
|
(stream-of 'sequence (sequence->generator '(1 2 3 4)))
|
|
'(1 2 3 4)
|
|
(#x2C #x11 #x12 #x13 #x14 #x3C))
|
|
(cross-check " [ -2 -1 0 1 ] " '(-2 -1 0 1) (#xC4 #x1E #x1F #x10 #x11))
|
|
(cross-check "\"hello\"" "hello" (#x55 "hello"))
|
|
(cross-check "\"hello\""
|
|
(stream-of 'string (sequence->generator '(#"he" #"llo")))
|
|
"hello"
|
|
(#x25 #x62 "he" #x63 "llo" #x35))
|
|
(cross-check "\"hello\""
|
|
(stream-of 'string (sequence->generator '(#"he" #"ll" #"" #"" #"o")))
|
|
"hello"
|
|
(#x25 #x62 "he" #x62 "ll" #x60 #x60 #x61 "o" #x35))
|
|
(cross-check "#\"hello\""
|
|
(stream-of 'byte-string (sequence->generator '(#"he" #"ll" #"" #"" #"o")))
|
|
#"hello"
|
|
(#x26 #x62 "he" #x62 "ll" #x60 #x60 #x61 "o" #x36))
|
|
(cross-check "hello"
|
|
(stream-of 'symbol (sequence->generator '(#"he" #"ll" #"" #"" #"o")))
|
|
'hello
|
|
(#x27 #x62 "he" #x62 "ll" #x60 #x60 #x61 "o" #x37))
|
|
(cross-check "[\"hello\" there #\"world\" [] #set{} #true #false]"
|
|
`("hello" there #"world" () ,(set) #t #f)
|
|
(#xC7 #x55 "hello" #x75 "there" #x65 "world" #xC0 #xD0 #x01 #x00))
|
|
|
|
(cross-check "#\"ABC\"" #"ABC" (#x63 #x41 #x42 #x43))
|
|
(cross-check "#hex{414243}" #"ABC" (#x63 #x41 #x42 #x43))
|
|
(cross-check "#hex{ 41 4A 4e }" #"AJN" (#x63 #x41 #x4A #x4E))
|
|
(cross-check "#hex{ 41;re\n 42 43 }" #"ABC" (#x63 #x41 #x42 #x43))
|
|
(check-exn exn? (lambda () (string->preserve "#hex{414 243}"))) ;; bytes must be 2-digits entire
|
|
(cross-check "#base64{Y29yeW1i}" #"corymb" (#x66 "corymb"))
|
|
(cross-check "#base64{Y29 yeW 1i}" #"corymb" (#x66 "corymb"))
|
|
(cross-check ";; a comment\n#base64{\n;x\nY29 yeW 1i}" #"corymb" (#x66 "corymb"))
|
|
(cross-check "#base64{SGk=}" #"Hi" (#x62 "Hi"))
|
|
(cross-check "#base64{SGk}" #"Hi" (#x62 "Hi"))
|
|
(cross-check "#base64{ S G k }" #"Hi" (#x62 "Hi"))
|
|
|
|
(check-equal? (string->preserve "[]") '())
|
|
(check-equal? (string->preserve "{}") (hash))
|
|
(check-equal? (string->preserve "\"\"") "")
|
|
(check-equal? (string->preserve "||") (string->symbol ""))
|
|
(check-equal? (string->preserve "#set{}") (set))
|
|
|
|
(check-equal? (string->preserve "{1 2 3}") (set 1 2 3))
|
|
(check-equal? (string->preserve "#set{1 2 3}") (set 1 2 3))
|
|
|
|
(cross-check "\"abc\\u6c34\\u6C34\\\\\\/\\\"\\b\\f\\n\\r\\txyz\""
|
|
"abc\u6c34\u6c34\\/\"\b\f\n\r\txyz"
|
|
(#x5f #x14
|
|
#x61 #x62 #x63 #xe6 #xb0 #xb4 #xe6 #xb0
|
|
#xb4 #x5c #x2f #x22 #x08 #x0c #x0a #x0d
|
|
#x09 #x78 #x79 #x7a))
|
|
|
|
(cross-check "|abc\\u6c34\\u6C34\\\\\\/\\|\\b\\f\\n\\r\\txyz|"
|
|
(string->symbol "abc\u6c34\u6c34\\/|\b\f\n\r\txyz")
|
|
(#x7f #x14
|
|
#x61 #x62 #x63 #xe6 #xb0 #xb4 #xe6 #xb0
|
|
#xb4 #x5c #x2f #x7c #x08 #x0c #x0a #x0d
|
|
#x09 #x78 #x79 #x7a))
|
|
|
|
(check-exn #px"Invalid escape code \\\\u" (lambda () (string->preserve "#\"\\u6c34\"")))
|
|
|
|
(cross-check "#\"abc\\x6c\\x34\\xf0\\\\\\/\\\"\\b\\f\\n\\r\\txyz\""
|
|
#"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz"
|
|
(#x6f #x11
|
|
#x61 #x62 #x63 #x6c #x34 #xf0 #x5c #x2f
|
|
#x22 #x08 #x0c #x0a #x0d #x09 #x78 #x79 #x7a))
|
|
|
|
(cross-check "\"\\uD834\\uDD1E\"" "\U0001D11E" (#x54 #xF0 #x9D #x84 #x9E))
|
|
|
|
(cross-check "-257" -257 (#x42 #xFE #xFF))
|
|
(cross-check "-256" -256 (#x42 #xFF #x00))
|
|
(cross-check "-255" -255 (#x42 #xFF #x01))
|
|
(cross-check "-254" -254 (#x42 #xFF #x02))
|
|
(cross-check "-129" -129 (#x42 #xFF #x7F))
|
|
(cross-check "-128" -128 (#x41 #x80))
|
|
(cross-check "-127" -127 (#x41 #x81))
|
|
(cross-check "-4" -4 (#x41 #xFC))
|
|
(cross-check "-3" -3 (#x1D))
|
|
(cross-check "-2" -2 (#x1E))
|
|
(cross-check "-1" -1 (#x1F))
|
|
(cross-check "0" 0 (#x10))
|
|
(cross-check "1" 1 (#x11))
|
|
(cross-check "12" 12 (#x1C))
|
|
(cross-check "13" 13 (#x41 #x0D))
|
|
(cross-check "127" 127 (#x41 #x7F))
|
|
(cross-check "128" 128 (#x42 #x00 #x80))
|
|
(cross-check "255" 255 (#x42 #x00 #xFF))
|
|
(cross-check "256" 256 (#x42 #x01 #x00))
|
|
(cross-check "32767" 32767 (#x42 #x7F #xFF))
|
|
(cross-check "32768" 32768 (#x43 #x00 #x80 #x00))
|
|
(cross-check "65535" 65535 (#x43 #x00 #xFF #xFF))
|
|
(cross-check "65536" 65536 (#x43 #x01 #x00 #x00))
|
|
(cross-check "131072" 131072 (#x43 #x02 #x00 #x00))
|
|
|
|
(cross-check "1.0f" 1.0f0 (#b00000010 #b00111111 #b10000000 0 0))
|
|
(cross-check "1.0" 1.0 (#b00000011 #b00111111 #b11110000 0 0 0 0 0 0))
|
|
(cross-check "-1.202e300" -1.202e300 (#x03 #xFE #x3C #xB7 #xB7 #x59 #xBF #x04 #x26))
|
|
|
|
(check-equal? (d (expected #x25 #x51 "a" #x35)) (void)) ;; Bad chunk type: must be bytes
|
|
(check-equal? (d (expected #x25 #x71 "a" #x35)) (void)) ;; Bad chunk type: must be bytes
|
|
(check-equal? (d (expected #x26 #x51 "a" #x36)) (void)) ;; Bad chunk type: must be bytes
|
|
(check-equal? (d (expected #x26 #x71 "a" #x36)) (void)) ;; Bad chunk type: must be bytes
|
|
(check-equal? (d (expected #x27 #x51 "a" #x37)) (void)) ;; Bad chunk type: must be bytes
|
|
(check-equal? (d (expected #x27 #x71 "a" #x37)) (void)) ;; Bad chunk type: must be bytes
|
|
(check-equal? (d (expected #x25 #x61 "a" #x35)) "a")
|
|
(check-equal? (d (expected #x26 #x61 "a" #x36)) #"a")
|
|
(check-equal? (d (expected #x27 #x61 "a" #x37)) 'a)
|
|
|
|
(struct date (year month day) #:prefab)
|
|
(struct thing (id) #:prefab)
|
|
(struct person thing (name date-of-birth) #:prefab)
|
|
(struct titled person (title) #:prefab)
|
|
|
|
(cross-check
|
|
"[titled person 2 thing 1](101, \"Blackwell\", date(1821 2 3), \"Dr\")"
|
|
(titled 101 "Blackwell" (date 1821 2 3) "Dr")
|
|
(#xB5 ;; Record, generic, 4+1
|
|
#xC5 ;; Sequence, 5
|
|
#x76 #x74 #x69 #x74 #x6C #x65 #x64 ;; Symbol, "titled"
|
|
#x76 #x70 #x65 #x72 #x73 #x6F #x6E ;; Symbol, "person"
|
|
#x12 ;; SignedInteger, "2"
|
|
#x75 #x74 #x68 #x69 #x6E #x67 ;; Symbol, "thing"
|
|
#x11 ;; SignedInteger, "1"
|
|
#x41 #x65 ;; SignedInteger, "101"
|
|
#x59 #x42 #x6C #x61 #x63 #x6B #x77 #x65 #x6C #x6C ;; String, "Blackwell"
|
|
#xB4 ;; Record, generic, 3+1
|
|
#x74 #x64 #x61 #x74 #x65 ;; Symbol, "date"
|
|
#x42 #x07 #x1D ;; SignedInteger, "1821"
|
|
#x12 ;; SignedInteger, "2"
|
|
#x13 ;; SignedInteger, "3"
|
|
#x52 #x44 #x72 ;; String, "Dr"
|
|
))
|
|
|
|
(cross-check "discard()" (record 'discard '()) (discard) (#x80))
|
|
(cross-check "discard(surprise)"
|
|
(record 'discard '(surprise))
|
|
'#s(discard surprise)
|
|
(#x81 #x78 "surprise"))
|
|
(cross-check "capture(x)" (record 'capture '(x)) (capture 'x) (#x91 #x71 "x"))
|
|
(cross-check "observe(x)" (record 'observe '(x)) (observe 'x) (#xA1 #x71 "x"))
|
|
(cross-check "observe(x y)" (record 'observe '(x y)) '#s(observe x y) (#xA2 #x71 "x" #x71 "y"))
|
|
(cross-check "other(x y)"
|
|
(record 'other '(x y))
|
|
'#s(other x y)
|
|
(#xB3 #x75 "other" #x71 "x" #x71 "y"))
|
|
(cross-check "\"aString\"(3 4)"
|
|
(record "aString" '(3 4))
|
|
(#xB3 #x57 "aString" #x13 #x14))
|
|
(cross-check "discard()(3, 4)"
|
|
(record (discard) '(3 4))
|
|
(#xB3 #x80 #x13 #x14))
|
|
|
|
(check-equal? (d (expected #x2C #x00 #x00)) (void)) ;; missing end byte
|
|
(check-equal? (d (expected #xC3 #x00 #x00)) (void)) ;; missing element
|
|
|
|
(cross-check/nondeterministic
|
|
"{a: 1, \"b\": #true, [1 2 3]: #\"c\", {first-name:\"Elizabeth\"}:{surname:\"Blackwell\"}}"
|
|
(hash 'a 1
|
|
"b" #t
|
|
'(1 2 3) #"c"
|
|
(hash 'first-name "Elizabeth") (hash 'surname "Blackwell"))
|
|
(#xE8 #x71 "a" #x11
|
|
#x51 "b" #x01
|
|
#xC3 #x11 #x12 #x13 #x61 "c"
|
|
#xE2 #x7A "first-name" #x59 "Elizabeth"
|
|
#xE2 #x77 "surname" #x59 "Blackwell"
|
|
))
|
|
|
|
(let ()
|
|
(local-require json)
|
|
(define rfc8259-example1 (string->preserve #<<EOF
|
|
{
|
|
"Image": {
|
|
"Width": 800,
|
|
"Height": 600,
|
|
"Title": "View from 15th Floor",
|
|
"Thumbnail": {
|
|
"Url": "http://www.example.com/image/481989943",
|
|
"Height": 125,
|
|
"Width": 100
|
|
},
|
|
"Animated" : false,
|
|
"IDs": [116, 943, 234, 38793]
|
|
}
|
|
}
|
|
EOF
|
|
))
|
|
(define rfc8259-example2 (string->preserve #<<EOF
|
|
[
|
|
{
|
|
"precision": "zip",
|
|
"Latitude": 37.7668,
|
|
"Longitude": -122.3959,
|
|
"Address": "",
|
|
"City": "SAN FRANCISCO",
|
|
"State": "CA",
|
|
"Zip": "94107",
|
|
"Country": "US"
|
|
},
|
|
{
|
|
"precision": "zip",
|
|
"Latitude": 37.371991,
|
|
"Longitude": -122.026020,
|
|
"Address": "",
|
|
"City": "SUNNYVALE",
|
|
"State": "CA",
|
|
"Zip": "94085",
|
|
"Country": "US"
|
|
}
|
|
]
|
|
EOF
|
|
))
|
|
|
|
(cross-check/nondeterministic
|
|
"{\"Image\": {\"Width\": 800,\"Height\": 600,\"Title\": \"View from 15th Floor\",\"Thumbnail\": {\"Url\": \"http://www.example.com/image/481989943\",\"Height\": 125,\"Width\": 100},\"Animated\" : false,\"IDs\": [116, 943, 234, 38793]}}"
|
|
rfc8259-example1
|
|
(#xe2
|
|
#x55 "Image"
|
|
#xec
|
|
#x55 "Width" #x42 #x03 #x20
|
|
#x55 "Title" #x5f #x14 "View from 15th Floor"
|
|
#x58 "Animated" #x75 "false"
|
|
#x56 "Height" #x42 #x02 #x58
|
|
#x59 "Thumbnail"
|
|
#xe6
|
|
#x55 "Width" #x41 #x64
|
|
#x53 "Url" #x5f #x26 "http://www.example.com/image/481989943"
|
|
#x56 "Height" #x41 #x7d
|
|
#x53 "IDs" #xc4
|
|
#x41 #x74
|
|
#x42 #x03 #xaf
|
|
#x42 #x00 #xea
|
|
#x43 #x00 #x97 #x89
|
|
))
|
|
|
|
(cross-check/nondeterministic
|
|
"[{\"precision\": \"zip\",\"Latitude\": 37.7668,\"Longitude\": -122.3959,\"Address\": \"\",\"City\": \"SAN FRANCISCO\",\"State\": \"CA\",\"Zip\": \"94107\",\"Country\": \"US\"},{\"precision\": \"zip\",\"Latitude\": 37.371991,\"Longitude\": -122.026020,\"Address\": \"\",\"City\": \"SUNNYVALE\",\"State\": \"CA\",\"Zip\": \"94085\",\"Country\": \"US\"}]"
|
|
rfc8259-example2
|
|
(#xc2
|
|
#xef #x10
|
|
#x59 "precision" #x53 "zip"
|
|
#x58 "Latitude" #x03 #x40 #x42 #xe2 #x26 #x80 #x9d #x49 #x52
|
|
#x59 "Longitude" #x03 #xc0 #x5e #x99 #x56 #x6c #xf4 #x1f #x21
|
|
#x57 "Address" #x50
|
|
#x54 "City" #x5D "SAN FRANCISCO"
|
|
#x55 "State" #x52 "CA"
|
|
#x53 "Zip" #x55 "94107"
|
|
#x57 "Country" #x52 "US"
|
|
#xef #x10
|
|
#x59 "precision" #x53 "zip"
|
|
#x58 "Latitude" #x03 #x40 #x42 #xaf #x9d #x66 #xad #xb4 #x03
|
|
#x59 "Longitude" #x03 #xc0 #x5e #x81 #xaa #x4f #xca #x42 #xaf
|
|
#x57 "Address" #x50
|
|
#x54 "City" #x59 "SUNNYVALE"
|
|
#x55 "State" #x52 "CA"
|
|
#x53 "Zip" #x55 "94085"
|
|
#x57 "Country" #x52 "US"
|
|
))
|
|
)
|
|
)
|