diff --git a/extra/cbor/authors.txt b/extra/cbor/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/cbor/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/cbor/cbor-docs.factor b/extra/cbor/cbor-docs.factor new file mode 100644 index 0000000000..099e5de047 --- /dev/null +++ b/extra/cbor/cbor-docs.factor @@ -0,0 +1,35 @@ +USING: byte-arrays help.markup help.syntax io kernel sequences strings ; + +IN: cbor + +HELP: read-cbor +{ $values { "obj" object } } +{ $description "Decodes an object that was serialized in the CBOR format, reading from an " { $link input-stream } "." } ; + +HELP: write-cbor +{ $values { "obj" object } } +{ $description "Encodes an object into the CBOR format, writing to an " { $link output-stream } "." } ; + +HELP: cbor> +{ $values { "seq" sequence } { "obj" object } } +{ $description "Decodes an object from the CBOR format, represented as a " { $link byte-array } " or " { $link string } "." } ; + +HELP: >cbor +{ $values { "obj" object } { "bytes" byte-array } } +{ $description "Encodes an object into the CBOR format." } ; + +ARTICLE: "cbor" "Concise Binary Object Representation (CBOR)" +"The Concise Binary Object Representation (CBOR) is defined in RFC 7049." +$nl +"Decoding support for the CBOR protocol:" +{ $subsections + read-cbor + cbor> +} +"Encoding support for the CBOR protocol:" +{ $subsections + write-cbor + >cbor +} ; + +ABOUT: "cbor" diff --git a/extra/cbor/cbor-tests.factor b/extra/cbor/cbor-tests.factor new file mode 100644 index 0000000000..411765d83f --- /dev/null +++ b/extra/cbor/cbor-tests.factor @@ -0,0 +1,33 @@ +USING: cbor tools.test ; + +{ 500 } [ B{ 0b000,11001 0x01 0xf4 } cbor> ] unit-test + +{ -500 } [ B{ 0b001,11001 0x01 0xf3 } cbor> ] unit-test + +{ { 1 { 2 3 } { 4 5 } } } [ + B{ 0x83 0x01 0x82 0x02 0x03 0x82 0x04 0x05 } cbor> +] unit-test + +{ { 1 { 2 3 } { 4 5 } } } [ + B{ 0x9F 0x01 0x82 0x02 0x03 0x9F 0x04 0x05 0xFF 0xFF } cbor> +] unit-test + +{ { 1 { 2 3 } { 4 5 } } } [ + B{ 0x9F 0x01 0x82 0x02 0x03 0x82 0x04 0x05 0xFF } cbor> +] unit-test + +{ { 1 { 2 3 } { 4 5 } } } [ + B{ 0x83 0x01 0x82 0x02 0x03 0x9F 0x04 0x05 0xFF } cbor> +] unit-test + +{ { 1 { 2 3 } { 4 5 } } } [ + B{ 0x83 0x01 0x9F 0x02 0x03 0xFF 0x82 0x04 0x05 } cbor> +] unit-test + +{ { { "Fun" t } { "Amt" -2 } } } [ + B{ 0xBF 0x63 0x46 0x75 0x6E 0xF5 0x63 0x41 0x6D 0x74 0x21 0xFF } cbor> +] unit-test + +{ B{ 0xaa 0xbb 0xcc 0xdd 0xee 0xff 0x99 } } [ + B{ 0x5F 0x44 0xaa 0xbb 0xcc 0xdd 0x43 0xee 0xff 0x99 0xff } cbor> +] unit-test diff --git a/extra/cbor/cbor.factor b/extra/cbor/cbor.factor new file mode 100644 index 0000000000..9899be3970 --- /dev/null +++ b/extra/cbor/cbor.factor @@ -0,0 +1,142 @@ +! Copyright (C) 2019 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: arrays assocs byte-arrays combinators io io.binary +io.encodings.binary io.encodings.string io.encodings.utf8 +io.streams.byte-array io.streams.string kernel math +math.bitwise math.floats.half sequences strings ; + +IN: cbor + +DEFER: read-cbor + +SINGLETON: +cbor-nil+ + +SINGLETON: +cbor-undefined+ + +SINGLETON: +cbor-break+ + +SINGLETON: +cbor-indefinite+ + + ] } + { 26 [ 4 read be> ] } + { 27 [ 8 read be> ] } + { 31 [ +cbor-indefinite+ ] } + } case + ] unless ; + +: read-bytestring ( info -- byte-array ) + read-unsigned dup +cbor-indefinite+ = [ + drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip concat + ] [ + read + ] if ; + +: read-textstring ( info -- string ) + read-bytestring utf8 decode ; + +: read-array ( info -- array ) + read-unsigned dup +cbor-indefinite+ = [ + drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip + ] [ + [ read-cbor ] replicate + ] if ; + +: read-map ( info -- alist ) + read-unsigned dup +cbor-indefinite+ = [ + drop [ read-cbor dup +cbor-break+ = not ] + [ read-cbor 2array ] produce nip + ] [ + [ read-cbor read-cbor 2array ] replicate + ] if ; + +: read-float ( info -- float ) + { + { 20 [ f ] } + { 21 [ t ] } + { 22 [ +cbor-nil+ ] } + { 23 [ +cbor-undefined+ ] } + { 25 [ 2 read be> bits>half ] } + { 26 [ 4 read be> bits>float ] } + { 27 [ 8 read be> bits>double ] } + { 31 [ +cbor-break+ ] } + } case ; + +PRIVATE> + +: read-cbor ( -- obj ) + read1 [ 5 bits ] [ -5 shift 3 bits ] bi { + { 0 [ read-unsigned ] } + { 1 [ read-unsigned neg 1 - ] } + { 2 [ read-bytestring ] } + { 3 [ read-textstring ] } + { 4 [ read-array ] } + { 5 [ read-map ] } + { 6 [ "optional semantic tagging not supported" throw ] } + { 7 [ read-float ] } + } case ; + +GENERIC: write-cbor ( obj -- ) + += [ + { + { [ dup 24 < ] [ write1 ] } + { [ dup 0xff <= ] [ 24 write1 write1 ] } + { [ dup 0xffff <= ] [ 25 write1 2 >be write ] } + { [ dup 0xffffffff <= ] [ 26 write1 4 >be write ] } + { [ dup 0xffffffffffffffff <= ] [ 27 write1 8 >be write ] } + } cond + ] [ + drop + ] if ; + +M: float write-cbor 0xfb write1 double>bits 8 >be write ; + +: write-length ( type n -- ) + [ 5 shift ] dip { + { [ dup 24 < ] [ bitor write1 ] } + { [ dup 0xff <= ] [ 24 bitor write1 write1 ] } + { [ dup 0xffff <= ] [ 25 bitor write1 2 >be write ] } + { [ dup 0xffffffff <= ] [ 26 bitor write1 4 >be write ] } + { [ dup 0xffffffffffffffff <= ] [ 27 bitor write1 8 >be write ] } + } cond ; + +M: byte-array write-cbor 2 over length write-length write ; + +M: string write-cbor 3 over length write-length utf8 encode write ; + +M: sequence write-cbor + 4 over length write-length [ write-cbor ] each ; + +M: assoc write-cbor + 5 over length write-length [ [ write-cbor ] bi@ ] assoc-each ; + +PRIVATE> + +GENERIC: cbor> ( seq -- obj ) + +M: string cbor> + [ read-cbor ] with-string-reader ; + +M: byte-array cbor> + binary [ read-cbor ] with-byte-reader ; + +: >cbor ( obj -- bytes ) + binary [ write-cbor ] with-byte-writer ; diff --git a/extra/cbor/summary.txt b/extra/cbor/summary.txt new file mode 100644 index 0000000000..4c5ccc2890 --- /dev/null +++ b/extra/cbor/summary.txt @@ -0,0 +1 @@ +Support for Concise Binary Object Representation (CBOR)