where's the shadow government
parent
5e60b94d81
commit
dba2883573
@ -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")))
|
||||
|
||||
|#
|
||||
@ -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)
|
||||
|#
|
||||
)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue