From c4f90ef86baf68e9a848a39d0086f9d6fc6f6a0a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 28 May 2020 23:21:51 +0200 Subject: [PATCH] Remove placeholders from spec and implementations 5/5 Update Racket implementation: remove placeholders; reject zero-length streamed binary chunks. --- .../racket/preserves/preserves/main.rkt | 203 ++++++++---------- 1 file changed, 93 insertions(+), 110 deletions(-) diff --git a/implementations/racket/preserves/preserves/main.rkt b/implementations/racket/preserves/preserves/main.rkt index 04836eb..83f54d9 100644 --- a/implementations/racket/preserves/preserves/main.rkt +++ b/implementations/racket/preserves/preserves/main.rkt @@ -18,8 +18,6 @@ current-binary-display-heuristics write-preserve preserve->string - current-value->placeholder - current-placeholder->value prepend-noop encode decode @@ -113,9 +111,6 @@ [(_ args ...) #'(peel-annotations-proc args ...)] [_ #'peel-annotations-proc]))) -(define current-value->placeholder (make-parameter (lambda (v) #f))) -(define current-placeholder->value (make-parameter (lambda (v) (void)))) - (define (prepend-noop encoded-value) (bit-string-append #"\xff" encoded-value)) @@ -182,52 +177,48 @@ (define (encode-value v) (define canonicalizing? (canonicalize-preserves?)) - (match (and (not canonicalizing?) ((current-value->placeholder) v)) - [(? integer? n) - (bit-string (#b0001 :: bits 4) (n :: (wire-length)))] - [#f - (let restart ((v 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))] - [(annotated annotations _ item) - (if canonicalizing? - (restart item) - (bit-string ((apply bit-string-append - (map (lambda (a) (bit-string #b00000101 ((encode-value a) :: binary))) - annotations)) :: binary) - ((encode-value item) :: binary)))] - [(? stream-of?) #:when canonicalizing? - (restart (stream-of->preserve v))] - [(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 2 1 (lambda (x) #t) (p))] - [(stream-of 'set p) (encode-stream 2 2 (lambda (x) #t) (p))] - [(stream-of 'dictionary p) (encode-stream 2 3 (lambda (x) #t) (p))] + (let restart ((v 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))] + [(annotated annotations _ item) + (if canonicalizing? + (restart item) + (bit-string ((apply bit-string-append + (map (lambda (a) (bit-string #b00000101 ((encode-value a) :: binary))) + annotations)) :: binary) + ((encode-value item) :: binary)))] + [(? stream-of?) #:when canonicalizing? + (restart (stream-of->preserve v))] + [(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 2 1 (lambda (x) #t) (p))] + [(stream-of 'set p) (encode-stream 2 2 (lambda (x) #t) (p))] + [(stream-of 'dictionary p) (encode-stream 2 3 (lambda (x) #t) (p))] - [(? integer? x) #:when (<= -3 x 12) (bit-string (#b0011 :: bits 4) (x :: bits 4))] - ;; [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 (string->bytes/utf-8 v))] - [(? bytes?) (encode-binary-like 2 v)] - [(? symbol?) (encode-binary-like 3 (string->bytes/utf-8 (symbol->string v)))] + [(? integer? x) #:when (<= -3 x 12) (bit-string (#b0011 :: bits 4) (x :: bits 4))] + ;; [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 (string->bytes/utf-8 v))] + [(? bytes?) (encode-binary-like 2 v)] + [(? symbol?) (encode-binary-like 3 (string->bytes/utf-8 (symbol->string v)))] - [(record label fields) (encode-array-like 0 (cons label fields))] - [(? list?) (encode-array-like 1 v)] - [(? set?) (encode-array-like 2 (if canonicalizing? - (canonical-set-elements v) - (set->list v)))] - [(? dict?) (encode-array-like 3 (if canonicalizing? - (canonical-dict-keys-and-values v) - (dict-keys-and-values v)))] + [(record label fields) (encode-array-like 0 (cons label fields))] + [(? list?) (encode-array-like 1 v)] + [(? set?) (encode-array-like 2 (if canonicalizing? + (canonical-set-elements v) + (set->list v)))] + [(? dict?) (encode-array-like 3 (if canonicalizing? + (canonical-dict-keys-and-values v) + (dict-keys-and-values v)))] - [_ (error 'encode-value "Cannot encode value ~v" v)]))])) + [_ (error 'encode-value "Cannot encode value ~v" v)]))) ;;--------------------------------------------------------------------------- @@ -317,10 +308,13 @@ (else (decode-one rest accept-one kf))))) - (define bytes-chunk? + (define (valid-unwrapped-chunk? c) + (and (bytes? c) (positive? (bytes-length c)))) + + (define valid-chunk? (if read-syntax? - (lambda (v) (bytes? (annotated-item v))) - bytes?)) + (lambda (v) (valid-unwrapped-chunk? (annotated-item v))) + valid-unwrapped-chunk?)) (define bytes-chunk-append* (if read-syntax? @@ -349,13 +343,11 @@ kf)) kf)) - ([ (= #b0001 :: bits 4) (placeholder :: (wire-length)) (rest :: binary) ] - (match ((current-placeholder->value) placeholder) - [(? void?) (error 'decode "Invalid Preserves placeholder: ~v" placeholder)] - [v ((nil-annotation ks bs) v rest)])) + ([ (= #b0001 :: bits 4) (rest :: binary) ] + (kf)) ([ (= #b001001 :: bits 6) (minor :: bits 2) (rest :: binary) ] - (decode-stream minor #f bytes-chunk? bytes-chunk-append* decode-binary rest ks kf)) + (decode-stream minor #f valid-chunk? bytes-chunk-append* decode-binary rest ks kf)) ([ (= #b001010 :: bits 6) (minor :: bits 2) (rest :: binary) ] (decode-stream minor #t (lambda (x) #t) values decode-compound rest ks kf)) @@ -979,13 +971,12 @@ (check-equal? (dwl (bytes 15 #b10101100 #b00000010)) 300) (check-equal? (dwl (bytes 15 #b10101100)) 'short) - (define (d bs) + (define (d bs #:allow-invalid-prefix? [allow-invalid-prefix? #f]) (for [(i (in-range 0 (- (bytes-length bs) 1)))] - (when (not (eq? (decode (subbytes bs 0 i) - #:on-short (lambda () 'short) - void) - 'short)) - (error 'd "~a-byte prefix of ~v does not read as short" i bs))) + (define result (decode (subbytes bs 0 i) #:on-short (lambda () 'short) void)) + (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))) (decode-syntax bs #:on-short (lambda () 'short) void)) @@ -1144,53 +1135,45 @@ (lambda (p) (port-count-lines! p) (read-preserve-syntax p #:source path))))) - (match-define (peel-annotations - `#s(TestCases - ,(strip-annotations - `#s(ExpectedPlaceholderMapping ,placeholder->value-map)) - ,tests)) - testfile) - (define value->placeholder-map (for/hash [((k v) (in-hash placeholder->value-map))] - (values v k))) - (parameterize - ((current-value->placeholder (lambda (v) (hash-ref value->placeholder-map v #f))) - (current-placeholder->value (lambda (p) (hash-ref placeholder->value-map p void)))) - (for [((t-name* t*) (in-hash (annotated-item tests)))] - (define t-name (strip-annotations t-name*)) - (define loc (format "Test case '~a' (~a)" t-name (source-location->string (annotated-srcloc t*)))) - (define (fail-test fmt . args) - (fail (format "~a: ~a" loc (apply format fmt args)))) - (displayln loc) - (match (peel-annotations t*) - [`#s(Test ,(strip-annotations binary-form) ,annotated-text-form) - (run-test-case 'normal t-name loc binary-form annotated-text-form)] - [`#s(NondeterministicTest ,(strip-annotations binary-form) ,annotated-text-form) - (run-test-case 'nondeterministic t-name loc binary-form annotated-text-form)] - [`#s(StreamingTest ,(strip-annotations binary-form) ,annotated-text-form) - (run-test-case 'streaming t-name loc binary-form annotated-text-form)] - [`#s(DecodeTest ,(strip-annotations binary-form) ,annotated-text-form) - (run-test-case 'decode t-name loc binary-form annotated-text-form)] - [`#s(ParseError ,(strip-annotations str)) - (with-handlers [(exn:fail:read:eof? - (lambda (e) (fail-test "Unexpected EOF: ~e" e))) - (exn:fail:read? - (lambda (e) 'ok)) - ((lambda (e) #t) - (lambda (e) (fail-test "Unexpected exception: ~e" e)))] - (string->preserve str) - (fail-test "Unexpected success"))] - [`#s(ParseShort ,(strip-annotations str)) - (with-handlers [(exn:fail:read:eof? (lambda (e) 'ok)) - ((lambda (e) #t) - (lambda (e) (fail-test "Unexpected exception: ~e" e)))] - (string->preserve str) - (fail-test "Unexpected success"))] - [`#s(DecodeShort ,(strip-annotations bs)) - (check-eq? (d bs) 'short loc)] - [`#s(DecodeError ,(strip-annotations bs)) - (check-true (void? (d bs)) loc)] - [_ - (write-preserve t* #:indent #f) - (newline)]))) + (match-define (peel-annotations `#s(TestCases ,tests)) testfile) + (for [((t-name* t*) (in-hash (annotated-item tests)))] + (define t-name (strip-annotations t-name*)) + (define loc (format "Test case '~a' (~a)" t-name (source-location->string (annotated-srcloc t*)))) + (define (fail-test fmt . args) + (fail (format "~a: ~a" loc (apply format fmt args)))) + (displayln loc) + (match (peel-annotations t*) + [`#s(Test ,(strip-annotations binary-form) ,annotated-text-form) + (run-test-case 'normal t-name loc binary-form annotated-text-form)] + [`#s(NondeterministicTest ,(strip-annotations binary-form) ,annotated-text-form) + (run-test-case 'nondeterministic t-name loc binary-form annotated-text-form)] + [`#s(StreamingTest ,(strip-annotations binary-form) ,annotated-text-form) + (run-test-case 'streaming t-name loc binary-form annotated-text-form)] + [`#s(DecodeTest ,(strip-annotations binary-form) ,annotated-text-form) + (run-test-case 'decode t-name loc binary-form annotated-text-form)] + [`#s(ParseError ,(strip-annotations str)) + (with-handlers [(exn:fail:read:eof? + (lambda (e) (fail-test "Unexpected EOF: ~e" e))) + (exn:fail:read? + (lambda (e) 'ok)) + ((lambda (e) #t) + (lambda (e) (fail-test "Unexpected exception: ~e" e)))] + (string->preserve str) + (fail-test "Unexpected success"))] + [(or `#s(ParseShort ,(strip-annotations str)) + `#s(ParseEOF ,(strip-annotations str))) + (with-handlers [(exn:fail:read:eof? (lambda (e) 'ok)) + ((lambda (e) #t) + (lambda (e) (fail-test "Unexpected exception: ~e" e)))] + (string->preserve str) + (fail-test "Unexpected success"))] + [(or `#s(DecodeShort ,(strip-annotations bs)) + `#s(DecodeEOF ,(strip-annotations bs))) + (check-eq? (d bs) 'short loc)] + [`#s(DecodeError ,(strip-annotations bs)) + (check-true (void? (d bs #:allow-invalid-prefix? #t)) loc)] + [_ + (write-preserve t* #:indent #f) + (newline)])) ) )