From dba2883573a5e5c97a2aa4e5634aff31ef9b9d70 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 12 Dec 2018 08:44:19 -0800 Subject: [PATCH] where's the shadow government --- .../redo/test/versioned-struct-test.rkt | 341 ++++++++++++++++++ xenomorph/xenomorph/redo/versioned-struct.rkt | 203 +++++++++++ 2 files changed, 544 insertions(+) create mode 100644 xenomorph/xenomorph/redo/test/versioned-struct-test.rkt create mode 100644 xenomorph/xenomorph/redo/versioned-struct.rkt diff --git a/xenomorph/xenomorph/redo/test/versioned-struct-test.rkt b/xenomorph/xenomorph/redo/test/versioned-struct-test.rkt new file mode 100644 index 00000000..86fb6d73 --- /dev/null +++ b/xenomorph/xenomorph/redo/test/versioned-struct-test.rkt @@ -0,0 +1,341 @@ +#lang debug racket/base +(require rackunit + sugar/unstable/dict + "../helper.rkt" + "../number.rkt" + "../string.rkt" + "../versioned-struct.rkt") + +#| +approximates +https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffee +|# + +(test-case + "decode should get version from number type" + (let ([vstruct (+xversioned-struct uint8 + (dictify + 0 (dictify 'name (+xstring uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+xstring uint8 'utf8) + 'age uint8 + 'gender uint8)))]) + + (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) + (check-equal? (dump (decode vstruct)) '((version . 0) (age . 21) (name . "roxyb")))) + + (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x0aroxyb 馃\x15\x00"))]) + (check-equal? (dump (decode vstruct)) '((version . 1) (age . 21) (name . "roxyb 馃") (gender . 0)))))) + +#| + +; it 'should throw for unknown version', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))]) + + (parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")]) + (check-exn exn:fail:contract? (位 () (decode struct))))) + + +; +; it 'should support common header block', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 'header (dictify 'age uint8 + 'alive uint8) + 0 (dictify 'name (+StringT uint8 'ascii)) + 1 (dictify 'name (+StringT uint8 'utf8) + 'gender uint8)))]) + + (parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")]) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb" + 'age 21 + 'alive 1 + 'version 0))) + + (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x15\x01\x0aroxyb 馃\x00"))]) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb 馃" + 'age 21 + 'version 1 + 'alive 1 + 'gender 0)))) + + +; it 'should support parent version key', -> + +(let ([struct (+VersionedStruct 'version + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))]) + + (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb" + 'age 21 + 'version 0))) + + (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 馃\x15\x00"))]) + (check-equal? (dump (decode struct #:parent (mhash 'version 1))) (hasheq 'name "roxyb 馃" + 'age 21 + 'version 1 + 'gender 0)))) + + + +; +; it 'should support sub versioned structs', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8)) + 1 (dictify 'name (+StringT uint8) + 'isDessert uint8)))))]) + + (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb" + 'age 21 + 'version 0))) + + (parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")]) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "pasta" + 'version 0))) + + (parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")]) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "ice cream" + 'isDessert 1 + 'version 1)))) + + +; +; it 'should support process hook', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))]) + (set-field! post-decode struct (位 (o stream ctx) (ref-set! o 'processed "true") o)) + (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb" + 'processed "true" + 'age 21 + 'version 0)))) + + +; +; describe 'size', -> +; it 'should compute the correct size', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))]) + + (check-equal? (size struct (mhasheq 'name "roxyb" + 'age 21 + 'version 0)) 8) + + (check-equal? (size struct (mhasheq 'name "roxyb 馃" + 'gender 0 + 'age 21 + 'version 1)) 14)) + + + + +; +; it 'should throw for unknown version', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))]) + + (check-exn exn:fail:contract? (位 () (size struct (mhasheq 'name "roxyb" + 'age 21 + 'version 5))))) + + +; +; it 'should support common header block', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 'header (dictify 'age uint8 + 'alive uint8) + 0 (dictify 'name (+StringT uint8 'ascii)) + 1 (dictify 'name (+StringT uint8 'utf8) + 'gender uint8)))]) + + (check-equal? (size struct (mhasheq 'name "roxyb" + 'age 21 + 'alive 1 + 'version 0)) 9) + + (check-equal? (size struct (mhasheq 'name "roxyb 馃" + 'gender 0 + 'age 21 + 'alive 1 + 'version 1)) 15)) + + + +; it 'should compute the correct size with pointers', -> + + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'ptr (+Pointer uint8 (+StringT uint8)))))]) + + (check-equal? (size struct (mhasheq 'name "roxyb" + 'age 21 + 'version 1 + 'ptr "hello")) 15)) + + +; +; it 'should throw if no value is given', -> + + + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))]) + + (check-exn exn:fail:contract? (位 () (size struct)))) + + + +; describe 'encode', -> +; it 'should encode objects to buffers', (done) -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))] + [port (open-output-bytes)]) + (encode struct (mhasheq 'name "roxyb" + 'age 21 + 'version 0) port) + (encode struct (mhasheq 'name "roxyb 馃" + 'age 21 + 'gender 0 + 'version 1) port) + (check-equal? (dump port) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 馃\x15\x00"))) + + +; +; it 'should throw for unknown version', -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))] + [port (open-output-bytes)]) + (check-exn exn:fail:contract? (位 () (encode struct port (mhasheq 'name "roxyb" + 'age 21 + 'version 5))))) + + + +; it 'should support common header block', (done) -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 'header (dictify 'age uint8 + 'alive uint8) + 0 (dictify 'name (+StringT uint8 'ascii)) + 1 (dictify 'name (+StringT uint8 'utf8) + 'gender uint8)))] + [stream (open-output-bytes)]) + + (encode struct (mhasheq 'name "roxyb" + 'age 21 + 'alive 1 + 'version 0) stream) + + (encode struct (mhasheq 'name "roxyb 馃" + 'gender 0 + 'age 21 + 'alive 1 + 'version 1) stream) + + (check-equal? (dump stream) (string->bytes/utf-8 "\x00\x15\x01\x05roxyb\x01\x15\x01\x0aroxyb 馃\x00"))) + + + +; it 'should encode pointer data after structure', (done) -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'ptr (+Pointer uint8 (+StringT uint8)))))] + [stream (open-output-bytes)]) + (encode struct (mhasheq 'version 1 + 'name "roxyb" + 'age 21 + 'ptr "hello") stream) + + (check-equal? (dump stream) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello"))) + + + + +; it 'should support preEncode hook', (done) -> + +(let ([struct (+VersionedStruct uint8 + (dictify + 0 (dictify 'name (+StringT uint8 'ascii) + 'age uint8) + 1 (dictify 'name (+StringT uint8 'utf8) + 'age uint8 + 'gender uint8)))] + [stream (open-output-bytes)]) + (set-field! pre-encode struct (位 (val port) (ref-set! val 'version (if (ref val 'gender) 1 0)) val)) + (encode struct (mhasheq 'name "roxyb" + 'age 21 + 'version 0) stream) + (encode struct (mhasheq 'name "roxyb 馃" + 'age 21 + 'gender 0) stream) + (check-equal? (dump stream) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 馃\x15\x00"))) + +|# \ No newline at end of file diff --git a/xenomorph/xenomorph/redo/versioned-struct.rkt b/xenomorph/xenomorph/redo/versioned-struct.rkt new file mode 100644 index 00000000..339a1f5b --- /dev/null +++ b/xenomorph/xenomorph/redo/versioned-struct.rkt @@ -0,0 +1,203 @@ +#lang racket/base +(require "helper.rkt" "struct.rkt" + racket/dict + sugar/unstable/dict) +(provide (all-defined-out)) + +#| +approximates +https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.coffee +|# + +(define (xversioned-struct-decode xvs [port-arg (current-input-port)] #:parent [parent #f] [length 0]) + (define port (->input-port port-arg)) + (define res (_setup port parent length)) + + (dict-set! res 'version + (cond + #;[forced-version] ; for testing purposes: pass an explicit version + [(or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))) + (unless parent + (raise-argument-error 'xversioned-struct-decode "valid parent" parent)) + ((xversioned-struct-version-getter xvs) parent)] + [else (decode (xversioned-struct-type xvs) port)])) + + (when (dict-ref (xversioned-struct-versions xvs) 'header #f) + (_parse-fields port res (dict-ref (xversioned-struct-versions xvs) 'header))) + + (define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref res 'version #f) #f) + (raise-argument-error 'xversioned-struct-decode "valid version key" (cons version (xversioned-struct-versions xvs))))) + + (cond + [(xversioned-struct? fields) (decode fields port #:parent parent)] + [else (_parse-fields port res fields) + res])) + +(define (xversioned-struct-size xvs [val #f] [parent #f]) + 42) + +(define (xversioned-struct-encode xvs val-arg [port-arg (current-output-port)] #:parent [parent #f]) + (define port (if (output-port? port-arg) port-arg (open-output-bytes))) + 42 + (unless port-arg (get-output-bytes port))) + +(struct xversioned-struct (type versions version-getter version-setter) #:transparent + #:methods gen:xenomorphic + [(define decode xversioned-struct-decode) + (define encode xversioned-struct-encode) + (define size xversioned-struct-size)]) + +(define (+xversioned-struct type [versions (dictify)]) + (unless (for/or ([proc (list integer? procedure? xenomorphic? symbol?)]) + (proc type)) + (raise-argument-error '+xversioned-struct "integer, procedure, symbol, or xenomorphic" type)) + (unless (and (dict? versions) (andmap (位 (v) (or (dict? v) (xstruct? v))) (dict-values versions))) + (raise-argument-error '+xversioned-struct "dict of dicts or xstructs" versions)) + (define version-getter (cond + [(procedure? type) type] + [(symbol? type) (位 (parent) (dict-ref parent type))])) + (define version-setter (cond + [(procedure? type) type] + [(symbol? type) (位 (parent version) (dict-set! parent type version))])) + (xversioned-struct type versions version-getter version-setter)) + +#| +(define-subclass Struct (VersionedStruct type [versions (dictify)]) + + (unless (for/or ([proc (list integer? procedure? xenomorph-base%? symbol?)]) + (proc type)) + (raise-argument-error 'VersionedStruct "integer, function, symbol, or Restructure object" type)) + (unless (and (dict? versions) (andmap (位 (val) (or (dict? val) (Struct? val))) (map cdr versions))) + (raise-argument-error 'VersionedStruct "dict of dicts or Structs" versions)) + + (inherit _setup _parse-fields post-decode) + (inherit-field fields) + (field [forced-version #f] + [versionGetter void] + [versionSetter void]) + + (when (or (key? type) (procedure? type)) + (set-field! versionGetter this (if (procedure? type) + type + (位 (parent) (ref parent type)))) + (set-field! versionSetter this (if (procedure? type) + type + (位 (parent version) (ref-set! parent type version))))) + + (define/override (decode stream [parent #f] [length 0]) + (define res (_setup stream parent length)) + + (ref-set! res 'version + (cond + [forced-version] ; for testing purposes: pass an explicit version + [(or (key? type) (procedure? type)) + (unless parent + (raise-argument-error 'VersionedStruct:decode "valid parent" parent)) + (versionGetter parent)] + [else (send type decode stream)])) + + (when (ref versions 'header) + (_parse-fields stream res (ref versions 'header))) + + (define fields (or (ref versions (ref res 'version)) (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (路 this versions))))) + + + (cond + [(VersionedStruct? fields) (send fields decode stream parent)] + [else + (_parse-fields stream res fields) + res])) + + (define/public-final (force-version! version) + (set! forced-version version)) + + (define/override (encode stream val [parent #f]) + (unless (hash? val) + (raise-argument-error 'VersionedStruct:encode "hash" val)) + + (define ctx (mhash 'pointers empty + 'startOffset (pos stream) + 'parent parent + 'val val + 'pointerSize 0)) + + (ref-set! ctx 'pointerOffset (+ (pos stream) (size val ctx #f))) + + (when (not (or (key? type) (procedure? type))) + (send type encode stream (or forced-version (路 val version)))) + + (when (ref versions 'header) + (for ([(key type) (in-dict (ref versions 'header))]) + (send type encode stream (ref val key) ctx))) + + (define fields (or (ref versions (or forced-version (路 val version))) (raise-argument-error 'VersionedStruct:encode "valid version key" version))) + + (unless (andmap (位 (key) (member key (ref-keys val))) (ref-keys fields)) + (raise-argument-error 'VersionedStruct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val))) + + (for ([(key type) (in-dict fields)]) + (send type encode stream (ref val key) ctx)) + + (for ([ptr (in-list (ref ctx 'pointers))]) + (send (ref ptr 'type) encode stream (ref ptr 'val) (ref ptr 'parent)))) + + + (define/override (size [val #f] [parent #f] [includePointers #t]) + (unless (or val forced-version) + (raise-argument-error 'VersionedStruct:size "value" val)) + + (define ctx (mhash 'parent parent + 'val val + 'pointerSize 0)) + + (+ (if (not (or (key? type) (procedure? type))) + (send type size (or forced-version (ref val 'version)) ctx) + 0) + + (for/sum ([(key type) (in-dict (or (ref versions 'header) empty))]) + (send type size (and val (ref val key)) ctx)) + + (let ([fields (or (ref versions (or forced-version (ref val 'version))) + (raise-argument-error 'VersionedStruct:encode "valid version key" version))]) + (for/sum ([(key type) (in-dict fields)]) + (send type size (and val (ref val key)) ctx))) + + (if includePointers (ref ctx 'pointerSize) 0)))) + +|# + +#;(test-module + (require "number.rkt") + (define (random-pick xs) (list-ref xs (random (length xs)))) + (check-exn exn:fail:contract? (位 () (+VersionedStruct 42 42))) + + ;; make random versioned structs and make sure we can round trip + #;(for ([i (in-range 1)]) + (define field-types (for/list ([i (in-range 1)]) + (random-pick (list uint8 uint16be uint16le uint32be uint32le double)))) + (define num-versions 20) + (define which-struct (random num-versions)) + (define struct-versions (for/list ([v (in-range num-versions)]) + (cons v (for/list ([num-type (in-list field-types)]) + (cons (gensym) num-type))))) + (define vs (+VersionedStruct which-struct struct-versions)) + (define struct-size (for/sum ([num-type (in-list (map cdr (ref struct-versions which-struct)))]) + (send num-type size))) + (define bs (apply bytes (for/list ([i (in-range struct-size)]) + (random 256)))) + (check-equal? (send vs encode #f (send vs decode bs)) bs)) + + (define s (+Struct (dictify 'a uint8 'b uint8 'c uint8))) + (check-equal? (send s size) 3) + (define vs (+VersionedStruct uint8 (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s)))) + (send vs force-version! 1) + (check-equal? (send vs size) 6) + #| + (define s2 (+Struct (dictify 'a vs))) + (check-equal? (send s2 size) 6) + (define vs2 (+VersionedStruct (位 (p) 2) (dictify 1 vs 2 vs))) + (check-equal? (send vs2 size) 6) +|# + ) + +