Racket blue implementation
This commit is contained in:
parent
e72adf704e
commit
666f8e1643
|
@ -0,0 +1,69 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide counted-iolist?
|
||||
counted-iolist-value
|
||||
counted-iolist-length
|
||||
count-iolist
|
||||
iolist-length
|
||||
iolist->bytes
|
||||
write-iolist)
|
||||
|
||||
(struct counted-iolist (value length) #:prefab)
|
||||
|
||||
(define (bad-iolist who v)
|
||||
(error who "Invalid iolist: ~v" v))
|
||||
|
||||
(define (iolist-length i [acc 0])
|
||||
(cond [(byte? i) (+ acc 1)]
|
||||
[(bytes? i) (+ acc (bytes-length i))]
|
||||
[(pair? i) (iolist-length (cdr i) (iolist-length (car i) acc))]
|
||||
[(null? i) acc]
|
||||
[(void? i) acc]
|
||||
[(counted-iolist? i) (+ acc (counted-iolist-length i))]
|
||||
[else (bad-iolist 'iolist-length i)]))
|
||||
|
||||
(define (count-iolist i)
|
||||
(if (counted-iolist? i)
|
||||
i
|
||||
(counted-iolist i (iolist-length i))))
|
||||
|
||||
(define (iolist->bytes i)
|
||||
(if (bytes? i)
|
||||
i
|
||||
(let ((buffer (make-bytes (iolist-length i))))
|
||||
(let walk ((i i) (offset 0))
|
||||
(cond [(byte? i) (bytes-set! buffer offset i) (+ offset 1)]
|
||||
[(bytes? i) (bytes-copy! buffer offset i) (+ offset (bytes-length i))]
|
||||
[(pair? i) (walk (cdr i) (walk (car i) offset))]
|
||||
[(null? i) offset]
|
||||
[(void? i) offset]
|
||||
[(counted-iolist? i) (walk (counted-iolist-value i) offset)]))
|
||||
buffer)))
|
||||
|
||||
(define (write-iolist i [out-port (current-output-port)])
|
||||
(cond [(byte? i) (write-byte i out-port)]
|
||||
[(bytes? i) (write-bytes i out-port)]
|
||||
[(pair? i) (write-iolist (car i) out-port) (write-iolist (cdr i) out-port)]
|
||||
[(null? i) (void)]
|
||||
[(void? i) (void)]
|
||||
[(counted-iolist? i) (write-iolist (counted-iolist-value i) out-port)]
|
||||
[else (bad-iolist 'write-iolist i)]))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require (only-in racket/port with-output-to-bytes))
|
||||
|
||||
(check-equal? (iolist-length '((1 . 1) (1 . #"xxx") . 1)) 7)
|
||||
(check-equal? (iolist-length '((1 . 1) (1 . #"xxx"))) 6)
|
||||
(check-equal? (iolist-length 123) 1)
|
||||
(check-equal? (iolist-length #"123") 3)
|
||||
(check-equal? (iolist-length (cons 123 #"123")) 4)
|
||||
|
||||
(check-equal? (iolist->bytes '((1 . 1) (1 . #"xxx") . 1)) (bytes 1 1 1 120 120 120 1))
|
||||
(check-equal? (iolist->bytes '((1 . 1) (1 . #"xxx"))) (bytes 1 1 1 120 120 120))
|
||||
(check-equal? (iolist->bytes 123) (bytes 123))
|
||||
(check-equal? (iolist->bytes #"123") (bytes 49 50 51))
|
||||
(check-equal? (iolist->bytes (cons 123 #"123")) (bytes 123 49 50 51))
|
||||
|
||||
(check-equal? (with-output-to-bytes (lambda () (write-iolist '((1 . 1) (1 . #"xxx") . 1))))
|
||||
(bytes 1 1 1 120 120 120 1)))
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide read-preserve/binary
|
||||
bytes->preserve)
|
||||
bytes->preserve
|
||||
preserve-sequence-reader)
|
||||
|
||||
(require racket/match)
|
||||
(require "record.rkt")
|
||||
|
@ -10,7 +11,7 @@
|
|||
(require "annotation.rkt")
|
||||
(require "varint.rkt")
|
||||
(require racket/set)
|
||||
(require (only-in racket/port call-with-input-bytes))
|
||||
(require (only-in racket/port call-with-input-bytes port->bytes))
|
||||
|
||||
(define (default-on-short) (error 'read-preserve/binary "Short Preserves binary"))
|
||||
(define (default-on-fail message . args) (error 'read-preserve/binary (apply format message args)))
|
||||
|
@ -21,7 +22,8 @@
|
|||
#:read-syntax? [read-syntax? #f]
|
||||
#:decode-embedded [decode-embedded #f]
|
||||
#:on-short [on-short default-on-short]
|
||||
[on-fail default-on-fail])
|
||||
[on-fail default-on-fail]
|
||||
[expected-input-length #f])
|
||||
(call-with-input-bytes
|
||||
bs
|
||||
(lambda (p)
|
||||
|
@ -29,27 +31,43 @@
|
|||
#:read-syntax? read-syntax?
|
||||
#:decode-embedded decode-embedded
|
||||
#:on-short on-short
|
||||
on-fail)
|
||||
on-fail
|
||||
expected-input-length)
|
||||
[(? eof-object?) (on-short)]
|
||||
[v v]))))
|
||||
|
||||
(define ((between lo hi) v) (<= lo v hi))
|
||||
|
||||
(define (read-preserve/binary [in-port (current-input-port)]
|
||||
#:read-syntax? [read-syntax? #f]
|
||||
#:decode-embedded [decode-embedded0 #f]
|
||||
#:on-short [on-short default-on-short]
|
||||
[on-fail default-on-fail])
|
||||
[on-fail default-on-fail]
|
||||
[expected-input-length #f])
|
||||
(define read-annotations? read-syntax?)
|
||||
(define decode-embedded (or decode-embedded0 default-decode-embedded))
|
||||
(let/ec return
|
||||
|
||||
(define (next) (wrap (pos) (next* (next-byte))))
|
||||
(define count expected-input-length)
|
||||
|
||||
(define (next* lead-byte)
|
||||
(match (next** lead-byte)
|
||||
['#:end (return (on-fail "Unexpected sequence end marker"))]
|
||||
[v v]))
|
||||
(define (eof-guard v)
|
||||
(if (eof-object? v)
|
||||
(return (on-short))
|
||||
v))
|
||||
|
||||
(define (next-byte) (eof-guard (next-byte*)))
|
||||
(define (next-byte*)
|
||||
(cond [(not count) (read-byte in-port)]
|
||||
[(zero? count) eof]
|
||||
[else (begin0 (read-byte in-port) (set! count (- count 1)))]))
|
||||
|
||||
(define (remaining-bytes)
|
||||
(if (not count)
|
||||
(port->bytes in-port)
|
||||
(let ((bs (eof-guard (read-bytes count in-port))))
|
||||
(if (< (bytes-length bs) count)
|
||||
(return (on-short))
|
||||
(begin0 bs (set! count 0))))))
|
||||
|
||||
(define (next) (wrap (pos) (next* (next-byte))))
|
||||
|
||||
(define pos
|
||||
(if read-syntax?
|
||||
|
@ -66,61 +84,109 @@
|
|||
(annotated '() (srcloc #f #f #f pos0 (- (pos) pos0)) v)))
|
||||
(lambda (pos0 v) v)))
|
||||
|
||||
(define (next** lead-byte)
|
||||
(match lead-byte
|
||||
[#x80 #f]
|
||||
[#x81 #t]
|
||||
[#x82 (float (floating-point-bytes->real (next-bytes 4) #t 0 4))]
|
||||
[#x83 (floating-point-bytes->real (next-bytes 8) #t 0 8)]
|
||||
[#x84 '#:end]
|
||||
[#x85 (let ((a (next)))
|
||||
(if read-annotations?
|
||||
(annotate (next) a)
|
||||
(next)))]
|
||||
[#x86 (embedded (decode-embedded (next)))]
|
||||
[(? (between #x90 #x9C) v) (- v #x90)]
|
||||
[(? (between #x9D #x9F) v) (- v #xA0)]
|
||||
[(? (between #xA0 #xAF) v) (next-integer (- v #xA0 -1))]
|
||||
[#xB0 (next-integer (next-varint))]
|
||||
[#xB1 (bytes->string/utf-8 (next-bytes (next-varint)))]
|
||||
[#xB2 (next-bytes (next-varint))]
|
||||
[#xB3 (string->symbol (bytes->string/utf-8 (next-bytes (next-varint))))]
|
||||
[#xB4 (apply (lambda (label . fields) (record label fields)) (next-items))]
|
||||
[#xB5 (next-items)]
|
||||
[#xB6 (list->set (next-items))]
|
||||
[#xB7 (build-dictionary (next-items))]
|
||||
[_ (return (on-fail "Invalid Preserves binary tag: ~v" lead-byte))]))
|
||||
(define (next* tag)
|
||||
(match tag
|
||||
[#xA0 #f]
|
||||
[#xA1 #t]
|
||||
[#xA2 (let ((bs (remaining-bytes)))
|
||||
(match (bytes-length bs)
|
||||
[4 (float (floating-point-bytes->real bs #t 0 4))]
|
||||
[8 (floating-point-bytes->real bs #t 0 8)]
|
||||
[n (return (on-fail "Invalid floating-point length: ~v" n))]))]
|
||||
[#xA3 (let* ((acc0 (initial-integer))
|
||||
(acc (if (< acc0 128) acc0 (- acc0 256))))
|
||||
(for/fold [(acc acc)] [(b (remaining-bytes))] (+ (* acc 256) b)))]
|
||||
[#xA4 (let* ((bs (remaining-bytes))
|
||||
(n (bytes-length bs)))
|
||||
(if (or (zero? n) (not (zero? (bytes-ref bs (- n 1)))))
|
||||
(return (on-fail "String not NUL terminated"))
|
||||
(bytes->string/utf-8 (subbytes bs 0 (- n 1)))))]
|
||||
[#xA5 (remaining-bytes)]
|
||||
[#xA6 (string->symbol (bytes->string/utf-8 (remaining-bytes)))]
|
||||
[#xA7 (apply (lambda (label . fields) (record label fields)) (next-items))]
|
||||
[#xA8 (next-items)]
|
||||
[#xA9 (list->set (next-items))]
|
||||
[#xAA (build-dictionary (next-items))]
|
||||
[#xAB (embedded (decode-embedded (next)))]
|
||||
[#xBF (if read-annotations?
|
||||
(apply annotate (next-items))
|
||||
(begin0 (next-item (next-byte)) (remaining-bytes)))]
|
||||
[_ (return (on-fail "Invalid Preserves binary tag: ~v" tag))]))
|
||||
|
||||
(define (eof-guard v)
|
||||
(if (eof-object? v)
|
||||
(return (on-short))
|
||||
v))
|
||||
(define (initial-integer)
|
||||
(cond [(not count) (match (read-byte in-port) [(? eof-object?) 0] [n n])]
|
||||
[(zero? count) 0]
|
||||
[else (next-byte)]))
|
||||
|
||||
(define (next-byte) (eof-guard (read-byte in-port)))
|
||||
|
||||
(define (next-bytes n)
|
||||
(define bs (eof-guard (read-bytes n in-port)))
|
||||
(if (< (bytes-length bs) n) (return (on-short)) bs))
|
||||
|
||||
(define (next-varint) (eof-guard (read-varint in-port)))
|
||||
|
||||
(define (next-integer n)
|
||||
(cond [(zero? n) 0]
|
||||
[else (define acc0 (next-byte))
|
||||
(define acc (if (< acc0 128) acc0 (- acc0 256)))
|
||||
(for/fold [(acc acc)] [(n (in-range (- n 1)))] (+ (* acc 256) (next-byte)))]))
|
||||
(define (next-item first-varint-byte)
|
||||
(define block-len (eof-guard (read-varint in-port first-varint-byte)))
|
||||
(define next-count (and count (- count block-len)))
|
||||
(set! count block-len)
|
||||
(begin0 (next) (set! count next-count)))
|
||||
|
||||
(define (next-items)
|
||||
(define pos0 (pos))
|
||||
(match (next** (next-byte))
|
||||
['#:end '()]
|
||||
[v (cons (wrap pos0 v) (next-items))]))
|
||||
(cond [(not count) (match (read-byte in-port)
|
||||
[(? eof-object?) '()]
|
||||
[n (cons (next-item n) (next-items))])]
|
||||
[(zero? count) '()]
|
||||
[else (cons (next-item (next-byte)) (next-items))]))
|
||||
|
||||
(define (build-dictionary items)
|
||||
(when (not (even? (length items))) (return (on-fail "Odd number of items in dictionary")))
|
||||
(apply hash items))
|
||||
|
||||
(let ((pos0 (pos)))
|
||||
(match (read-byte in-port)
|
||||
[(? eof-object?) eof]
|
||||
[lead-byte (wrap pos0 (next* lead-byte))]))))
|
||||
(if (not count)
|
||||
(let ((pos0 (pos)))
|
||||
(match (next-byte*)
|
||||
[(? eof-object?) eof]
|
||||
[tag (wrap pos0 (next* tag))]))
|
||||
(next))))
|
||||
|
||||
(define (read-preserve/binary/length-prefix [in-port (current-input-port)]
|
||||
#:read-syntax? [read-syntax? #f]
|
||||
#:decode-embedded [decode-embedded #f]
|
||||
#:on-short [on-short default-on-short]
|
||||
[on-fail default-on-fail])
|
||||
(if (eof-object? (peek-byte in-port))
|
||||
eof
|
||||
(match (read-varint in-port)
|
||||
[(? eof-object?) (on-short)]
|
||||
[block-len (read-preserve/binary in-port
|
||||
#:read-syntax? read-syntax?
|
||||
#:decode-embedded decode-embedded
|
||||
#:on-short on-short
|
||||
on-fail
|
||||
block-len)])))
|
||||
|
||||
(define (preserve-sequence-reader [in-port (current-input-port)]
|
||||
#:read-syntax? [read-syntax? #f]
|
||||
#:decode-embedded [decode-embedded #f]
|
||||
#:on-short [on-short default-on-short]
|
||||
[on-fail default-on-fail])
|
||||
(if (eqv? (peek-byte in-port) #xA8)
|
||||
(begin (read-byte in-port)
|
||||
(lambda () (read-preserve/binary/length-prefix in-port
|
||||
#:read-syntax? read-syntax?
|
||||
#:decode-embedded decode-embedded
|
||||
#:on-short on-short
|
||||
on-fail)))
|
||||
#f))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require (only-in file/sha1 hex-string->bytes))
|
||||
|
||||
(let ((r (preserve-sequence-reader (open-input-bytes
|
||||
(hex-string->bytes "a882a30182a30281a381")))))
|
||||
(check-equal? (r) 1)
|
||||
(check-equal? (r) 2)
|
||||
(check-equal? (r) 0)
|
||||
(check-exn #px"Short Preserves binary" (lambda () (r))))
|
||||
|
||||
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "82a301"))) 1)
|
||||
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "82a302"))) 2)
|
||||
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "81a3"))) 0)
|
||||
|
||||
(check-equal? (read-preserve/binary/length-prefix (open-input-bytes (hex-string->bytes "81"))
|
||||
#:on-short (lambda () 'short))
|
||||
'short))
|
||||
|
|
|
@ -43,134 +43,132 @@
|
|||
"13/14 and 16/17, depending on how they wish to treat end-of-stream conditions."
|
||||
]>
|
||||
<TestCases {
|
||||
annotation1: <Test #x"85B10361626399" @"abc" 9>
|
||||
annotation2: <Test #x"85B10361626385B103646566B5B58485B10178B58484" @"abc" @"def" [[] @"x" []]>
|
||||
annotation3: <Test #x"858591928585939495" @@1 2 @@3 4 5>
|
||||
annotation4: <NondeterministicTest #x"B7 85 B302616b B30161 85 B3026176 91 85 B302626b B30162 85 B3026276 92 84"
|
||||
annotation1: <Test #x"BF 82A309 85A461626300" @"abc" 9>
|
||||
annotation2: <Test #x"BF 8BA881A887BF81A883A47800 85A461626300 85A464656600" @"abc" @"def" [[] @"x" []]>
|
||||
annotation3: <Test #x"BF 82A305 87BF82A30282A301 87BF82A30482A303" @@1 2 @@3 4 5>
|
||||
annotation4: <NondeterministicTest #x"AA 88BF82A66183A6616B 88BF82A30183A66276 88BF82A66283A6626B 88BF82A30283A66276"
|
||||
{@ak a: @av 1 @bk b: @bv 2}>
|
||||
annotation5: <Test #x"85B3026172B4B3015285B3026166B3016684" @ar <R @af f>>
|
||||
annotation6: <Test #x"B485B3026172B3015285B3026166B3016684" <@ar R @af f>>
|
||||
annotation5: <Test #x"BF8DA782A65288BF82A66683A6616683A66172" @ar <R @af f>>
|
||||
annotation6: <Test #x"A788BF82A65283A6617288BF82A66683A66166" <@ar R @af f>>
|
||||
annotation7:
|
||||
;Stop reading symbols at @ -- this test has three separate annotations
|
||||
<Test #x"85B3016185B3016285B30163B584" @a@b@c[]>
|
||||
bytes2: <Test #x"B20568656c6c6f" #"hello">
|
||||
bytes2a: <Test @"Internal whitespace is allowed, including commas!" #x"B2, 05, 68, 65, 6c, 6c, 6f" #"hello">
|
||||
bytes3: <Test #x"B203414243" #"ABC">
|
||||
bytes4: <Test #x"B203414243" #x"414243">
|
||||
bytes5: <Test #x"B203414a4e" #x" 41 4A 4e ">
|
||||
<Test #x"BF81A882A66182A66282A663" @a@b@c[]>
|
||||
bytes2: <Test #x"a568656c6c6f" #"hello">
|
||||
bytes2a: <Test @"Internal whitespace is allowed, including commas!" #x"a5, 68, 65, 6c, 6c, 6f" #"hello">
|
||||
bytes3: <Test #x"a5414243" #"ABC">
|
||||
bytes4: <Test #x"a5414243" #x"414243">
|
||||
bytes5: <Test #x"a5414a4e" #x" 41 4A 4e ">
|
||||
bytes6: @"Bytes must be 2-digits entire" <ParseError "#x\"414 243\"">
|
||||
bytes7: <Test #"\xB2\x06corymb" #[Y29yeW1i]>
|
||||
bytes8: <Test #"\xB2\x06corymb" #[Y29 yeW 1i]>
|
||||
bytes9: <Test #"\xB2\x02Hi" #[SGk=]>
|
||||
bytes10: <Test #"\xB2\x02Hi" #[SGk]>
|
||||
bytes11: <Test #"\xB2\x02Hi" #[S G k]>
|
||||
bytes7: <Test #"\xa5corymb" #[Y29yeW1i]>
|
||||
bytes8: <Test #"\xa5corymb" #[Y29 yeW 1i]>
|
||||
bytes9: <Test #"\xa5Hi" #[SGk=]>
|
||||
bytes10: <Test #"\xa5Hi" #[SGk]>
|
||||
bytes11: <Test #"\xa5Hi" #[S G k]>
|
||||
bytes12: @"Bytes syntax only supports \\x, not \\u" <ParseError "#\"\\u6c34\"">
|
||||
bytes13: <Test #x"B2 11 61 62 63 6c 34 f0 5c 2f 22 08 0c 0a 0d 09 78 79 7a" #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz">
|
||||
bytes13: <Test #x"a5 61 62 63 6c 34 f0 5c 2f 22 08 0c 0a 0d 09 78 79 7a" #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz">
|
||||
|
||||
dict0: <Test #x"B784" {}>
|
||||
dict1: <NondeterministicTest #x"b7 b10162 81 b30161 91 b591929384 b20163 b7 b30a66697273742d6e616d65 b109456c697a6162657468 84 b7 b3077375726e616d65 b109426c61636b77656c6c 84 84" { a: 1 "b": #t [1 2 3]: #"c" { first-name: "Elizabeth" }: { surname: "Blackwell" } }>
|
||||
dict0: <Test #x"aa" {}>
|
||||
dict1: <NondeterministicTest #x"aa 83a46200 81a1 82a661 82a301 8aa882a30182a30282a303 82a563 99aa8ba666697273742d6e616d658ba4456c697a616265746800 96aa88a67375726e616d658ba4426c61636b77656c6c00" { a: 1 "b": #t [1 2 3]: #"c" { first-name: "Elizabeth" }: { surname: "Blackwell" } }>
|
||||
dict2: @"Missing close brace" <ParseShort "{ a: b, c: d ">
|
||||
dict2a: @"Missing close brace" <ParseShort "{">
|
||||
dict3: @"Duplicate key" <ParseError "{ a: 1, a: 2 }">
|
||||
dict4: @"Unexpected close brace" <ParseError "}">
|
||||
dict5: @"Missing value" <DecodeError #x"b7 91 92 93 84">
|
||||
double1: <Test #x"833ff0000000000000" 1.0>
|
||||
double2: <Test #x"83fe3cb7b759bf0426" -1.202e300>
|
||||
float1: <Test #x"823f800000" 1.0f>
|
||||
int-257: <Test #x"a1feff" -257>
|
||||
int-256: <Test #x"a1ff00" -256>
|
||||
int-255: <Test #x"a1ff01" -255>
|
||||
int-254: <Test #x"a1ff02" -254>
|
||||
int-129: <Test #x"a1ff7f" -129>
|
||||
int-128: <Test #x"a080" -128>
|
||||
int-127: <Test #x"a081" -127>
|
||||
int-4: <Test #x"a0fc" -4>
|
||||
int-3: <Test #x"9d" -3>
|
||||
int-2: <Test #x"9e" -2>
|
||||
int-1: <Test #x"9f" -1>
|
||||
int0: <Test #x"90" 0>
|
||||
int1: <Test #x"91" 1>
|
||||
int12: <Test #x"9c" 12>
|
||||
int13: <Test #x"a00d" 13>
|
||||
int127: <Test #x"a07f" 127>
|
||||
int128: <Test #x"a10080" 128>
|
||||
int255: <Test #x"a100ff" 255>
|
||||
int256: <Test #x"a10100" 256>
|
||||
int32767: <Test #x"a17fff" 32767>
|
||||
int32768: <Test #x"a2008000" 32768>
|
||||
int65535: <Test #x"a200ffff" 65535>
|
||||
int65536: <Test #x"a2010000" 65536>
|
||||
int131072: <Test #x"a2020000" 131072>
|
||||
int2500000000: <Test #x"a4009502f900" 2500000000>
|
||||
int87112285931760246646623899502532662132736: <Test #x"b012010000000000000000000000000000000000" 87112285931760246646623899502532662132736>
|
||||
list0: <Test #x"b584" []>
|
||||
list4: <Test #x"b59192939484" [1 2 3 4]>
|
||||
list4a: <Test #x"b59192939484" [1, 2, 3, 4]>
|
||||
list5: <Test #x"b59e9f909184" [-2 -1 0 1]>
|
||||
list6: <Test #x"b5 b10568656c6c6f b3057468657265 b205776f726c64 b584 b684 81 80 84" ["hello" there #"world" [] #{} #t #f]>
|
||||
list7: <Test #x"b5 b303616263 b3032e2e2e b303646566 84" [abc ... def]>
|
||||
dict5: @"Missing value" <DecodeError #x"aa 82a301 82a302 82a303">
|
||||
double1: <Test #x"a23ff0000000000000" 1.0>
|
||||
double2: <Test #x"a2fe3cb7b759bf0426" -1.202e300>
|
||||
float1: <Test #x"a23f800000" 1.0f>
|
||||
int-257: <Test #x"a3feff" -257>
|
||||
int-256: <Test #x"a3ff00" -256>
|
||||
int-255: <Test #x"a3ff01" -255>
|
||||
int-254: <Test #x"a3ff02" -254>
|
||||
int-129: <Test #x"a3ff7f" -129>
|
||||
int-128: <Test #x"a380" -128>
|
||||
int-127: <Test #x"a381" -127>
|
||||
int-4: <Test #x"a3fc" -4>
|
||||
int-3: <Test #x"a3fd" -3>
|
||||
int-2: <Test #x"a3fe" -2>
|
||||
int-1: <Test #x"a3ff" -1>
|
||||
int0: <Test #x"a3" 0>
|
||||
int1: <Test #x"a301" 1>
|
||||
int12: <Test #x"a30c" 12>
|
||||
int13: <Test #x"a30d" 13>
|
||||
int127: <Test #x"a37f" 127>
|
||||
int128: <Test #x"a30080" 128>
|
||||
int255: <Test #x"a300ff" 255>
|
||||
int256: <Test #x"a30100" 256>
|
||||
int32767: <Test #x"a37fff" 32767>
|
||||
int32768: <Test #x"a3008000" 32768>
|
||||
int65535: <Test #x"a300ffff" 65535>
|
||||
int65536: <Test #x"a3010000" 65536>
|
||||
int131072: <Test #x"a3020000" 131072>
|
||||
int2500000000: <Test #x"a3009502f900" 2500000000>
|
||||
int87112285931760246646623899502532662132736: <Test #x"a3010000000000000000000000000000000000" 87112285931760246646623899502532662132736>
|
||||
list0: <Test #x"a8" []>
|
||||
list4: <Test #x"a882a30182a30282a30382a304" [1 2 3 4]>
|
||||
list4a: <Test #x"a882a30182a30282a30382a304" [1, 2, 3, 4]>
|
||||
list5: <Test #x"a882a3fe82a3ff81a382a301" [-2 -1 0 1]>
|
||||
list6: <Test #x"a8 87a468656c6c6f00 86a67468657265 86a5776f726c64 81a8 81a9 81a1 81a0" ["hello" there #"world" [] #{} #t #f]>
|
||||
list7: <Test #x"a8 84a6616263 84a62e2e2e 84a6646566" [abc ... def]>
|
||||
list8: @"Missing close bracket" <ParseShort "[">
|
||||
list9: @"Unexpected close bracket" <ParseError "]">
|
||||
list10: @"Missing end byte" <DecodeShort #x"b58080">
|
||||
list10: @"Missing tag" <DecodeShort #x"a881">
|
||||
noinput0: @"No input at all" <DecodeEOF #x"">
|
||||
embed0: <Test #x"8690" #!0>
|
||||
embed1: <Test #x"868690" #!#!0>
|
||||
embed2: <Test #x"b5869086b10568656c6c6f84" [#!0 #!"hello"]>
|
||||
record1: <Test #x"b4 b30763617074757265 b4 b30764697363617264 84 84" <capture <discard>>>
|
||||
record2: <Test #x"b4 b3076f627365727665 b4 b305737065616b b4 b30764697363617264 84 b4 b30763617074757265 b4 b30764697363617264 84 84 84 84" <observe <speak <discard>, <capture <discard>>>>>
|
||||
record3: <Test #x"b4 b5 b3067469746c6564 b306706572736f6e 92 b3057468696e67 91 84 a065 b109426c61636b77656c6c b4 b30464617465 a1071d 92 93 84 b1024472 84" <[titled person 2 thing 1] 101 "Blackwell" <date 1821 2 3> "Dr">>
|
||||
record4: <Test #x"b4 b30764697363617264 84" <discard>>
|
||||
record5: <Test #x"b497b58484" <7[]>>
|
||||
record6: <Test #x"b4b30764697363617264b308737572707269736584" <discard surprise>>
|
||||
record7: <Test #x"b4b10761537472696e67939484" <"aString" 3 4>>
|
||||
record8: <Test #x"b4b4b3076469736361726484939484" <<discard> 3 4>>
|
||||
embed0: <Test #x"aba3" #!0>
|
||||
embed1: <Test #x"ababa3" #!#!0>
|
||||
embed2: <Test #x"a8 82aba3 88aba468656c6c6f00" [#!0 #!"hello"]>
|
||||
record1: <Test #x"a7 88a663617074757265 8aa788a664697363617264" <capture <discard>>>
|
||||
record2: <Test #x"a7 88a66f627365727665 a9a7 86a6737065616b 8aa788a664697363617264 95a7 88a663617074757265 8aa788a664697363617264" <observe <speak <discard>, <capture <discard>>>>>
|
||||
record3: <Test #x"a7 9e a8 87a67469746c6564 87a6706572736f6e 82a302 86a67468696e67 82a301 82a365 8ba4426c61636b77656c6c00 91a7 85a664617465 83a3071d 82a302 82a303 84a4447200" <[titled person 2 thing 1] 101 "Blackwell" <date 1821 2 3> "Dr">>
|
||||
record4: <Test #x"a788a664697363617264" <discard>>
|
||||
record5: <Test #x"a782a30781a8" <7[]>>
|
||||
record6: <Test #x"a788a66469736361726489a67375727072697365" <discard surprise>>
|
||||
record7: <Test #x"a789a461537472696e670082a30382a304" <"aString" 3 4>>
|
||||
record8: <Test #x"a78aa788a66469736361726482a30382a304" <<discard> 3 4>>
|
||||
record9: @"Missing record label" <ParseError "<>">
|
||||
record10: @"Missing close-angle-bracket" <ParseShort "<">
|
||||
record11: @"Unexpected close-angle-bracket" <ParseError ">">
|
||||
set0: <Test #x"b684" #{}>
|
||||
set1: <NondeterministicTest #x"b691929384" #{1 2 3}>
|
||||
set0: <Test #x"a9" #{}>
|
||||
set1: <NondeterministicTest #x"a982a30182a30282a303" #{1 2 3}>
|
||||
set2: @"Missing close brace" <ParseShort "#{ 1 2 3 ">
|
||||
set2a: @"Missing close brace" <ParseShort "#{">
|
||||
set3: @"Duplicate value" <ParseError "#{a a}">
|
||||
string0: <Test #x"b100" "">
|
||||
string3: <Test #x"b10568656c6c6f" "hello">
|
||||
string4: <Test #x"b1 14 616263e6b0b4e6b0b45c2f22080c0a0d0978797a" "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz">
|
||||
string5: <Test #x"b104f09d849e" "\uD834\uDD1E">
|
||||
symbol0: <Test #x"b300" ||>
|
||||
symbol2: <Test #x"b30568656c6c6f" hello>
|
||||
tag0: @"Unexpected end tag" <DecodeError #x"84">
|
||||
string0: <Test #x"a400" "">
|
||||
string3: <Test #x"a468656c6c6f00" "hello">
|
||||
string4: <Test #x"a4616263e6b0b4e6b0b45c2f22080c0a0d0978797a00" "abc\u6c34\u6C34\\/\"\b\f\n\r\txyz">
|
||||
string5: <Test #x"a4f09d849e00" "\uD834\uDD1E">
|
||||
symbol0: <Test #x"a6" ||>
|
||||
symbol2: <Test #x"a668656c6c6f" hello>
|
||||
tag1: @"Invalid tag" <DecodeError #x"10">
|
||||
tag2: @"Invalid tag" <DecodeError #x"61b10110">
|
||||
tag2: @"Invalid tag" <DecodeError #x"61a30110">
|
||||
whitespace0: @"Leading spaces have to eventually yield something" <ParseShort " ">
|
||||
whitespace1: @"No input at all" <ParseEOF "">
|
||||
value1: <Test #"\xB2\x06corymb" #=#"\xB2\x06corymb">
|
||||
value2: <Test #"\x81" #=#"\x81">
|
||||
value3: <Test #"\x81" #=#[gQ]>
|
||||
value4: <Test #"\x81" #=#[gQ==]>
|
||||
value5: <Test #"\x81" #= #[gQ==]>
|
||||
value6: <Test #x"b591929384" #=#x"b591929384">
|
||||
value1: <Test #"\xA5corymb" #=#"\xA5corymb">
|
||||
value2: <Test #"\xA1" #=#"\xA1">
|
||||
value3: <Test #"\xA1" #=#[oQ]>
|
||||
value4: <Test #"\xA1" #=#[oQ==]>
|
||||
value5: <Test #"\xA1" #= #[oQ==]>
|
||||
value6: <Test #x"A882A30182A30282A303" #=#x"A882A30182A30282A303">
|
||||
|
||||
longlist14: <Test #x"b5808080808080808080808080808084"
|
||||
longlist14: <Test #x"a881a081a081a081a081a081a081a081a081a081a081a081a081a081a0"
|
||||
[#f #f #f #f #f
|
||||
#f #f #f #f #f
|
||||
#f #f #f #f]>
|
||||
longlist15: <Test #x"b580808080808080808080808080808084"
|
||||
longlist15: <Test #x"a881a081a081a081a081a081a081a081a081a081a081a081a081a081a081a0"
|
||||
[#f #f #f #f #f
|
||||
#f #f #f #f #f
|
||||
#f #f #f #f #f]>
|
||||
longlist100:
|
||||
<Test #x"b5
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
84"
|
||||
<Test #x"a8
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0"
|
||||
[#f #f #f #f #f #f #f #f #f #f
|
||||
#f #f #f #f #f #f #f #f #f #f
|
||||
#f #f #f #f #f #f #f #f #f #f
|
||||
|
@ -182,28 +180,27 @@
|
|||
#f #f #f #f #f #f #f #f #f #f
|
||||
#f #f #f #f #f #f #f #f #f #f]>
|
||||
longlist200:
|
||||
<Test #x"b5
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
80808080808080808080
|
||||
84"
|
||||
<Test #x"a8
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0
|
||||
81a081a081a081a081a081a081a081a081a081a0"
|
||||
[#f #f #f #f #f #f #f #f #f #f
|
||||
#f #f #f #f #f #f #f #f #f #f
|
||||
#f #f #f #f #f #f #f #f #f #f
|
||||
|
@ -226,35 +223,22 @@
|
|||
#f #f #f #f #f #f #f #f #f #f]>
|
||||
|
||||
rfc8259-example1: <NondeterministicTest
|
||||
#x"B7
|
||||
B1 05 496d616765
|
||||
B7
|
||||
B1 03 494473
|
||||
B5
|
||||
A0 74
|
||||
A1 03 AF
|
||||
A1 00 EA
|
||||
A2 00 97 89
|
||||
84
|
||||
B1 05 5469746c65
|
||||
B1 14 566965772066726f6d203135746820466c6f6f72
|
||||
B1 05 5769647468
|
||||
A1 03 20
|
||||
B1 06 486569676874
|
||||
A1 02 58
|
||||
B1 08 416e696d61746564
|
||||
B3 05 66616c7365
|
||||
B1 09 5468756d626e61696c
|
||||
B7
|
||||
B1 03 55726c
|
||||
B1 26 687474703a2f2f7777772e6578616d706c652e636f6d2f696d6167652f343831393839393433
|
||||
B1 05 5769647468
|
||||
A0 64
|
||||
B1 06 486569676874
|
||||
A0 7D
|
||||
84
|
||||
84
|
||||
84"
|
||||
#x"AA
|
||||
87 A4 496D61676500
|
||||
01B7 AA
|
||||
8A A4 416E696D6174656400 86 A6 66616C7365
|
||||
88 A4 48656967687400 83 A3 0258
|
||||
85 A4 49447300 91 A8
|
||||
82 A3 74
|
||||
83 A3 03AF
|
||||
83 A3 00EA
|
||||
84 A3 009789
|
||||
8B A4 5468756D626E61696C00 C7 AA
|
||||
88 A4 48656967687400 82 A3 7D
|
||||
85 A4 55726C00 A8 A4 687474703A2F2F7777772E6578616D706C652E636F6D2F696D6167652F34383139383939343300
|
||||
87 A4 576964746800 82 A3 64
|
||||
87 A4 5469746C6500 96 A4 566965772066726F6D203135746820466C6F6F7200
|
||||
87 A4 576964746800 83 A3 0320"
|
||||
{
|
||||
"Image": {
|
||||
"Width": 800,
|
||||
|
@ -271,28 +255,25 @@
|
|||
}>
|
||||
|
||||
rfc8259-example2: <NondeterministicTest
|
||||
#x"b5
|
||||
b7
|
||||
b1 03 5a6970 b1 05 3934313037
|
||||
b1 04 43697479 b1 0d 53414e204652414e434953434f
|
||||
b1 05 5374617465 b1 02 4341
|
||||
b1 07 41646472657373 b1 00
|
||||
b1 07 436f756e747279 b1 02 5553
|
||||
b1 08 4c61746974756465 83 4042e226809d4952
|
||||
b1 09 4c6f6e676974756465 83 c05e99566cf41f21
|
||||
b1 09 707265636973696f6e b1 03 7a6970
|
||||
84
|
||||
b7
|
||||
b1 03 5a6970 b1 05 3934303835
|
||||
b1 04 43697479 b1 09 53554e4e5956414c45
|
||||
b1 05 5374617465 b1 02 4341
|
||||
b1 07 41646472657373 b1 00
|
||||
b1 07 436f756e747279 b1 02 5553
|
||||
b1 08 4c61746974756465 83 4042af9d66adb403
|
||||
b1 09 4c6f6e676974756465 83 c05e81aa4fca42af
|
||||
b1 09 707265636973696f6e b1 03 7a6970
|
||||
84
|
||||
84"
|
||||
#x"a8
|
||||
018c aa
|
||||
89 a4 4164647265737300 82 a4 00
|
||||
86 a4 4369747900 8f a4 53414e204652414e434953434f00
|
||||
89 a4 436f756e74727900 84 a4 555300
|
||||
8a a4 4c6174697475646500 89 a2 4042e226809d4952
|
||||
8b a4 4c6f6e67697475646500 89 a2 c05e99566cf41f21
|
||||
87 a4 537461746500 84 a4 434100
|
||||
85 a4 5a697000 87 a4 393431303700
|
||||
8b a4 707265636973696f6e00 85 a4 7a697000
|
||||
0188 aa
|
||||
89 a4 4164647265737300 82 a4 00
|
||||
86 a4 4369747900 8b a4 53554e4e5956414c4500
|
||||
89 a4 436f756e74727900 84 a4 555300
|
||||
8a a4 4c6174697475646500 89 a2 4042af9d66adb403
|
||||
8b a4 4c6f6e67697475646500 89 a2 c05e81aa4fca42af
|
||||
87 a4 537461746500 84 a4 434100
|
||||
85 a4 5a697000 87 a4 393430383500
|
||||
8b a4 707265636973696f6e00 85 a4 7a697000"
|
||||
[
|
||||
{
|
||||
"precision": "zip",
|
||||
|
|
|
@ -13,7 +13,9 @@
|
|||
(for [(i (in-range 1 (- (bytes-length bs) 1)))]
|
||||
(define result (bytes->preserve (subbytes bs 0 i)
|
||||
#:decode-embedded strip-annotations
|
||||
#:on-short (lambda () 'short) void))
|
||||
#:on-short (lambda () 'short)
|
||||
void
|
||||
(bytes-length bs)))
|
||||
(when (and (not (eq? result 'short))
|
||||
(not (and allow-invalid-prefix? (void? result))))
|
||||
(error 'd "~a-byte prefix of ~v does not read as short; result: ~v" i bs result)))
|
||||
|
|
|
@ -1,33 +1,31 @@
|
|||
#lang racket/base
|
||||
;; "varints" from Google Protocol Buffers,
|
||||
;; https://developers.google.com/protocol-buffers/docs/encoding#varints
|
||||
;;
|
||||
;; "Each byte in a varint, except the last byte, has the most
|
||||
;; significant bit (msb) set – this indicates that there are further
|
||||
;; bytes to come. The lower 7 bits of each byte are used to store the
|
||||
;; two's complement representation of the number in groups of 7 bits,
|
||||
;; least significant group first."
|
||||
|
||||
(provide write-varint
|
||||
(provide varint->iolist
|
||||
write-varint
|
||||
read-varint
|
||||
encode-varint
|
||||
decode-varint)
|
||||
|
||||
(require racket/port)
|
||||
|
||||
(define (write-varint v out-port)
|
||||
(if (< v 128)
|
||||
(write-byte v out-port)
|
||||
(begin (write-byte (+ 128 (modulo v 128)) out-port)
|
||||
(write-varint (quotient v 128) out-port))))
|
||||
(define (varint->iolist n)
|
||||
(let wr ((n n) (d 128))
|
||||
(if (< n 128)
|
||||
(+ d n)
|
||||
(cons (wr (quotient n 128) 0) (+ d (modulo n 128))))))
|
||||
|
||||
(define (read-varint in-port)
|
||||
(let/ec return
|
||||
(let loop ()
|
||||
(define b (read-byte in-port))
|
||||
(cond [(eof-object? b) (return b)]
|
||||
[(< b 128) b]
|
||||
[else (+ (* (loop) 128) (- b 128))]))))
|
||||
(define (write-varint n out-port)
|
||||
(let wr ((n n) (d 128))
|
||||
(if (< n 128)
|
||||
(write-byte (+ d n) out-port)
|
||||
(begin (wr (quotient n 128) 0)
|
||||
(write-byte (+ d (modulo n 128)) out-port)))))
|
||||
|
||||
(define (read-varint in-port [first-byte (read-byte in-port)])
|
||||
(let rd ((acc 0) (b first-byte))
|
||||
(cond [(eof-object? b) eof]
|
||||
[(< b 128) (rd (+ (* acc 128) b) (read-byte in-port))]
|
||||
[else (+ (* acc 128) (- b 128))])))
|
||||
|
||||
(define (encode-varint v)
|
||||
(call-with-output-bytes (lambda (p) (write-varint v p))))
|
||||
|
@ -42,28 +40,28 @@
|
|||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(check-equal? (encode-varint 0) (bytes 0))
|
||||
(check-equal? (encode-varint 1) (bytes 1))
|
||||
(check-equal? (encode-varint 127) (bytes 127))
|
||||
(check-equal? (encode-varint 128) (bytes 128 1))
|
||||
(check-equal? (encode-varint 255) (bytes 255 1))
|
||||
(check-equal? (encode-varint 256) (bytes 128 2))
|
||||
(check-equal? (encode-varint 300) (bytes #b10101100 #b00000010))
|
||||
(check-equal? (encode-varint 1000000000) (bytes 128 148 235 220 3))
|
||||
(check-equal? (encode-varint 0) (bytes 128))
|
||||
(check-equal? (encode-varint 1) (bytes 129))
|
||||
(check-equal? (encode-varint 127) (bytes 255))
|
||||
(check-equal? (encode-varint 128) (bytes 1 128))
|
||||
(check-equal? (encode-varint 255) (bytes 1 255))
|
||||
(check-equal? (encode-varint 256) (bytes 2 128))
|
||||
(check-equal? (encode-varint 300) (bytes #b00000010 #b10101100))
|
||||
(check-equal? (encode-varint 1000000000) (bytes 3 92 107 20 128))
|
||||
|
||||
(define (ks* v rest) (list v rest))
|
||||
(define (kf* [short? #f]) (if short? 'short (void)))
|
||||
|
||||
(check-equal? (decode-varint (bytes) ks* kf*) 'short)
|
||||
(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) ks* kf*) 'short)
|
||||
(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? (decode-varint (bytes 128) ks* kf*) (list 0 (bytes)))
|
||||
(check-equal? (decode-varint (bytes 128 99) ks* kf*) (list 0 (bytes 99)))
|
||||
(check-equal? (decode-varint (bytes 129) ks* kf*) (list 1 (bytes)))
|
||||
(check-equal? (decode-varint (bytes 255) ks* kf*) (list 127 (bytes)))
|
||||
(check-equal? (decode-varint (bytes 0) ks* kf*) 'short)
|
||||
(check-equal? (decode-varint (bytes 1 128) ks* kf*) (list 128 (bytes)))
|
||||
(check-equal? (decode-varint (bytes 1 128 99) ks* kf*) (list 128 (bytes 99)))
|
||||
(check-equal? (decode-varint (bytes 1 255) ks* kf*) (list 255 (bytes)))
|
||||
(check-equal? (decode-varint (bytes 2 128) ks* kf*) (list 256 (bytes)))
|
||||
(check-equal? (decode-varint (bytes #b00000010 #b10101100) ks* kf*) (list 300 (bytes)))
|
||||
(check-equal? (decode-varint (bytes 3 92 107 20 128) ks* kf*) (list 1000000000 (bytes)))
|
||||
(check-equal? (decode-varint (bytes 3 92 107 20 128 99) ks* kf*) (list 1000000000 (bytes 99))))
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide write-preserve/binary
|
||||
preserve->bytes)
|
||||
(provide preserve->iolist
|
||||
preserve->bytes
|
||||
write-preserve/binary)
|
||||
|
||||
(require racket/match)
|
||||
(require (only-in racket/port call-with-output-bytes))
|
||||
|
@ -11,120 +12,97 @@
|
|||
(require "annotation.rkt")
|
||||
(require "varint.rkt")
|
||||
(require "object-id.rkt")
|
||||
(require "iolist.rkt")
|
||||
(require racket/set)
|
||||
(require racket/dict)
|
||||
(require (only-in racket/list flatten))
|
||||
|
||||
(define (preserve->iolist v
|
||||
#:canonicalizing? [canonicalizing? #t]
|
||||
#:encode-embedded [encode-embedded0 #f]
|
||||
#:write-annotations? [write-annotations? (not canonicalizing?)])
|
||||
(define encode-embedded (or encode-embedded0 object-id))
|
||||
|
||||
(define (prepare v)
|
||||
(iolist->bytes (preserve->iolist v #:canonicalizing? #t #:encode-embedded encode-embedded0)))
|
||||
|
||||
(define (length-prefixed-iolist i)
|
||||
(define c (count-iolist i))
|
||||
(cons (varint->iolist (counted-iolist-length c)) c))
|
||||
|
||||
(define (length-prefixed v) (length-prefixed-iolist (encode v)))
|
||||
|
||||
(define (encode v)
|
||||
(match v
|
||||
[#f #xA0]
|
||||
[#t #xA1]
|
||||
[(float v) (cons #xA2 (real->floating-point-bytes v 4 #t))]
|
||||
[(? flonum?) (cons #xA2 (real->floating-point-bytes v 8 #t))]
|
||||
[(? integer?) (cons #xA3 (when (not (zero? v))
|
||||
(define nbits (bitwise-and (+ (integer-length v) 8) -8))
|
||||
(for/list [(shift (in-range nbits 0 -8))]
|
||||
(bitwise-bit-field v (- shift 8) shift))))]
|
||||
[(? string?) (list #xA4 (string->bytes/utf-8 v) 0)]
|
||||
[(? bytes?) (cons #xA5 v)]
|
||||
[(? symbol?) (cons #xA6 (string->bytes/utf-8 (symbol->string v)))]
|
||||
[(record label fields) (list #xA7 (length-prefixed label) (map length-prefixed fields))]
|
||||
[(? list?) (cons #xA8 (map length-prefixed v))]
|
||||
[(? set?) (cons #xA9 (set->iolist v))]
|
||||
[(? dict?) (cons #xAA (dict->iolist v))]
|
||||
[(embedded value) (cons #xAB (encode (encode-embedded value)))]
|
||||
|
||||
[(annotated as _ v)
|
||||
(if (and write-annotations? (pair? as))
|
||||
(list #xBF (length-prefixed v) (map length-prefixed as))
|
||||
(encode v))]
|
||||
|
||||
[other (error 'preserve->iolist "Attempt to serialize non-preserve: ~v" other)]))
|
||||
|
||||
(define set->iolist
|
||||
(match* [canonicalizing? write-annotations?]
|
||||
[[#t #f] (lambda (v)
|
||||
(map length-prefixed-iolist
|
||||
(sort (for/list [(e (in-set v))] (prepare e)) bytes<?)))]
|
||||
[[#t #t] (lambda (v)
|
||||
(map length-prefixed
|
||||
(map cdr (sort (for/list [(e (in-set v))] (cons (prepare e) e))
|
||||
bytes<? #:key car))))]
|
||||
[[#f _] (lambda (v)
|
||||
(for/list [(e (in-set v))] (length-prefixed e)))]))
|
||||
|
||||
(define (prepare-dict d)
|
||||
(sort (for/list [((k v) (in-dict d))] (list (prepare k) k v)) bytes<? #:key car))
|
||||
|
||||
(define dict->iolist
|
||||
(match* [canonicalizing? write-annotations?]
|
||||
[[#t #f] (lambda (v)
|
||||
(map (match-lambda [(list kb _ v) (cons (length-prefixed-iolist kb)
|
||||
(length-prefixed v))])
|
||||
(prepare-dict v)))]
|
||||
[[#t #t] (lambda (v)
|
||||
(map (match-lambda [(list _ k v) (cons (length-prefixed k)
|
||||
(length-prefixed v))])
|
||||
(prepare-dict v)))]
|
||||
[[#f _] (lambda (v)
|
||||
(for/list [((k v) (in-dict v))] (cons (length-prefixed k) (length-prefixed v))))]))
|
||||
|
||||
(encode v))
|
||||
|
||||
(define (preserve->bytes v
|
||||
#:canonicalizing? [canonicalizing? #t]
|
||||
#:encode-embedded [encode-embedded #f]
|
||||
#:write-annotations? [write-annotations? (not canonicalizing?)])
|
||||
(call-with-output-bytes
|
||||
(lambda (p) (write-preserve/binary v p
|
||||
#:canonicalizing? canonicalizing?
|
||||
#:encode-embedded encode-embedded
|
||||
#:write-annotations? write-annotations?))))
|
||||
(iolist->bytes (preserve->iolist v
|
||||
#:canonicalizing? canonicalizing?
|
||||
#:encode-embedded encode-embedded
|
||||
#:write-annotations? write-annotations?)))
|
||||
|
||||
(define (write-preserve/binary v [out-port (current-output-port)]
|
||||
#:canonicalizing? [canonicalizing? #t]
|
||||
#:encode-embedded [encode-embedded0 #f]
|
||||
#:encode-embedded [encode-embedded #f]
|
||||
#:write-annotations? [write-annotations? (not canonicalizing?)])
|
||||
(define encode-embedded (or encode-embedded0 object-id))
|
||||
|
||||
(define (output-byte b)
|
||||
(write-byte b out-port))
|
||||
|
||||
(define (output-bytes bs)
|
||||
(write-bytes bs out-port))
|
||||
|
||||
(define (output-varint v)
|
||||
(write-varint v out-port))
|
||||
|
||||
(define-syntax-rule (with-seq tag body ...)
|
||||
(begin (output-byte (+ tag #xB0))
|
||||
body ...
|
||||
(output-byte #x84)))
|
||||
|
||||
(define (count-bytes tag bs)
|
||||
(output-byte (+ tag #xB0))
|
||||
(output-varint (bytes-length bs))
|
||||
(output-bytes bs))
|
||||
|
||||
(define (prepare v) (preserve->bytes v #:canonicalizing? #t))
|
||||
|
||||
(define (output-all vs)
|
||||
(for [(v (in-list vs))] (output v)))
|
||||
|
||||
(define output-set
|
||||
(match* [canonicalizing? write-annotations?]
|
||||
[[#t #f] (lambda (v)
|
||||
(for-each output-bytes
|
||||
(sort (for/list [(e (in-set v))] (prepare e)) bytes<?)))]
|
||||
[[#t #t] (lambda (v)
|
||||
(for-each output
|
||||
(map cdr
|
||||
(sort (for/list [(e (in-set v))] (cons (prepare e) e))
|
||||
bytes<?
|
||||
#:key car))))]
|
||||
[[#f _] (lambda (v) (for [(e (in-set v))] (output e)))]))
|
||||
|
||||
(define (prepare-dict d)
|
||||
(sort (for/list [((k v) (in-dict d))] (list (prepare k) k v)) bytes<? #:key car))
|
||||
|
||||
(define output-dict
|
||||
(match* [canonicalizing? write-annotations?]
|
||||
[[#t #f] (lambda (v)
|
||||
(for-each (match-lambda [(list kb _ v) (output-bytes kb) (output v)])
|
||||
(prepare-dict v)))]
|
||||
[[#t #t] (lambda (v)
|
||||
(for-each (match-lambda [(list _ k v) (output k) (output v)])
|
||||
(prepare-dict v)))]
|
||||
[[#f _] (lambda (v) (for [((k v) (in-dict v))] (output k) (output v)))]))
|
||||
|
||||
(define (output v)
|
||||
(match v
|
||||
[#f (output-byte #x80)]
|
||||
[#t (output-byte #x81)]
|
||||
|
||||
[(float v)
|
||||
(output-byte #x82)
|
||||
(output-bytes (real->floating-point-bytes v 4 #t))]
|
||||
[(? flonum?)
|
||||
(output-byte #x83)
|
||||
(output-bytes (real->floating-point-bytes v 8 #t))]
|
||||
|
||||
[(annotated as _ v)
|
||||
(when write-annotations?
|
||||
(for [(a (in-list as))]
|
||||
(output-byte #x85)
|
||||
(output a)))
|
||||
(output v)]
|
||||
|
||||
[(? integer?)
|
||||
(cond [(<= -3 v -1) (output-byte (+ v #xA0))]
|
||||
[(<= 0 v 12) (output-byte (+ v #x90))]
|
||||
[else (define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
|
||||
(define byte-count (quotient (+ raw-bit-count 7) 8))
|
||||
(if (<= byte-count 16)
|
||||
(output-byte (+ byte-count #xA0 -1))
|
||||
(begin (output-byte #xB0)
|
||||
(output-varint byte-count)))
|
||||
(for [(shift (in-range (* byte-count 8) 0 -8))]
|
||||
(output-byte (bitwise-bit-field v (- shift 8) shift)))])]
|
||||
|
||||
[(? string?) (count-bytes 1 (string->bytes/utf-8 v))]
|
||||
[(? bytes?) (count-bytes 2 v)]
|
||||
[(? symbol?) (count-bytes 3 (string->bytes/utf-8 (symbol->string v)))]
|
||||
|
||||
[(record label fields) (with-seq 4 (output label) (output-all fields))]
|
||||
[(? list?) (with-seq 5 (output-all v))]
|
||||
[(? set?) (with-seq 6 (output-set v))]
|
||||
[(? dict?) (with-seq 7 (output-dict v))]
|
||||
|
||||
[(embedded value)
|
||||
(output-byte #x86)
|
||||
(output (encode-embedded value))]
|
||||
|
||||
[other (error 'write-preserve/binary "Attempt to serialize non-preserve: ~v" other)]))
|
||||
|
||||
(output v))
|
||||
(write-iolist (preserve->iolist v
|
||||
#:canonicalizing? canonicalizing?
|
||||
#:encode-embedded encode-embedded
|
||||
#:write-annotations? write-annotations?)
|
||||
out-port))
|
||||
|
|
Loading…
Reference in New Issue