basis/cbor/cbor.factor

   1 ! Copyright (C) 2019 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays assocs base64 byte-arrays calendar
   5 calendar.format calendar.parser combinators endian io
   6 io.encodings.binary io.encodings.string io.encodings.utf8
   7 io.streams.byte-array io.streams.string kernel math math.bitwise
   8 math.floats.half present sequences strings urls ;
   9
  10 IN: cbor
  11
  12 DEFER: read-cbor
  13
  14 SINGLETON: +cbor-nil+
  15
  16 SINGLETON: +cbor-undefined+
  17
  18 SINGLETON: +cbor-break+
  19
  20 SINGLETON: +cbor-indefinite+
  21
  22 TUPLE: cbor-tagged tag item ;
  23
  24 TUPLE: cbor-simple value ;
  25
  26 <PRIVATE
  27
  28 : read-unsigned ( info -- n )
  29     dup 24 < [
  30         {
  31             { 24 [ read1 ] }
  32             { 25 [ 2 read be> ] }
  33             { 26 [ 4 read be> ] }
  34             { 27 [ 8 read be> ] }
  35             { 31 [ +cbor-indefinite+ ] }
  36         } case
  37     ] unless ;
  38
  39 : read-bytestring ( info -- byte-array )
  40     read-unsigned dup +cbor-indefinite+ = [
  41         drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip concat
  42     ] [
  43         read [ B{ } ] unless*
  44     ] if ;
  45
  46 : read-textstring ( info -- string )
  47     read-bytestring utf8 decode ;
  48
  49 : read-array ( info -- array )
  50     read-unsigned dup +cbor-indefinite+ = [
  51         drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip
  52     ] [
  53         [ read-cbor ] replicate
  54     ] if ;
  55
  56 : read-map ( info -- alist )
  57     read-unsigned dup +cbor-indefinite+ = [
  58         drop [ read-cbor dup +cbor-break+ = not ]
  59         [ read-cbor 2array ] produce nip
  60     ] [
  61         [ read-cbor read-cbor 2array ] replicate
  62     ] if ;
  63
  64 : read-tagged ( info -- tagged )
  65     read-unsigned read-cbor swap {
  66         { 0 [ rfc3339>timestamp ] }
  67         { 1 [ unix-time>timestamp ] }
  68         { 2 [ be> ] }
  69         { 3 [ be> neg 1 - ] }
  70         { 32 [ >url ] }
  71         { 33 [ base64> ] }
  72         [ swap cbor-tagged boa ]
  73     } case ;
  74
  75 : read-float ( info -- float )
  76     dup 20 < [ cbor-simple boa ] [
  77         {
  78             { 20 [ f ] }
  79             { 21 [ t ] }
  80             { 22 [ +cbor-nil+ ] }
  81             { 23 [ +cbor-undefined+ ] }
  82             { 24 [ read1 cbor-simple boa ] }
  83             { 25 [ 2 read be> bits>half ] }
  84             { 26 [ 4 read be> bits>float ] }
  85             { 27 [ 8 read be> bits>double ] }
  86             { 31 [ +cbor-break+ ] }
  87         } case
  88     ] if ;
  89
  90 PRIVATE>
  91
  92 : read-cbor ( -- obj )
  93     read1 [ 5 bits ] [ -5 shift 3 bits ] bi {
  94         { 0 [ read-unsigned ] }
  95         { 1 [ read-unsigned neg 1 - ] }
  96         { 2 [ read-bytestring ] }
  97         { 3 [ read-textstring ] }
  98         { 4 [ read-array ] }
  99         { 5 [ read-map ] }
 100         { 6 [ read-tagged ] }
 101         { 7 [ read-float ] }
 102     } case ;
 103
 104 GENERIC: write-cbor ( obj -- )
 105
 106 <PRIVATE
 107
 108 M: f write-cbor drop 0xf4 write1 ;
 109
 110 M: t write-cbor drop 0xf5 write1 ;
 111
 112 M: +cbor-nil+ write-cbor drop 0xf6 write1 ;
 113
 114 M: +cbor-undefined+ write-cbor drop 0xf7 write1 ;
 115
 116 : write-integer ( n type -- )
 117     5 shift {
 118         { [ over 24 < ] [ bitor write1 ] }
 119         { [ over 0xff <= ] [ 24 bitor write1 write1 ] }
 120         { [ over 0xffff <= ] [ 25 bitor write1 2 >be write ] }
 121         { [ over 0xffffffff <= ] [ 26 bitor write1 4 >be write ] }
 122         { [ over 0xffffffffffffffff <= ] [ 27 bitor write1 8 >be write ] }
 123         [
 124             -5 shift 2 + 0xc0 bitor write1
 125             dup bit-length 8 /mod zero? [ 1 + ] unless
 126             >be write-cbor
 127         ]
 128     } cond ;
 129
 130 M: integer write-cbor
 131     dup 0 >= [ 0 write-integer ] [ neg 1 - 1 write-integer ] if ;
 132
 133 M: float write-cbor 0xfb write1 double>bits 8 >be write ;
 134
 135 M: byte-array write-cbor dup length 2 write-integer write ;
 136
 137 M: string write-cbor dup length 3 write-integer utf8 encode write ;
 138
 139 M: sequence write-cbor
 140     dup length 4 write-integer [ write-cbor ] each ;
 141
 142 M: assoc write-cbor
 143     dup length 5 write-integer [ [ write-cbor ] bi@ ] assoc-each ;
 144
 145 M: timestamp write-cbor
 146     0 6 write-integer timestamp>rfc3339 write-cbor ;
 147
 148 M: url write-cbor
 149     32 6 write-integer present write-cbor ;
 150
 151 M: cbor-tagged write-cbor
 152     dup tag>> 6 write-integer item>> write-cbor ;
 153
 154 M: cbor-simple write-cbor
 155     value>> 7 write-integer ;
 156
 157 PRIVATE>
 158
 159 GENERIC: cbor> ( seq -- obj )
 160
 161 M: string cbor>
 162     [ read-cbor ] with-string-reader ;
 163
 164 M: byte-array cbor>
 165     binary [ read-cbor ] with-byte-reader ;
 166
 167 : >cbor ( obj -- bytes )
 168     binary [ write-cbor ] with-byte-writer ;