basis/msgpack/msgpack.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: arrays assocs byte-arrays combinators endian grouping
   5 hashtables io io.encodings io.encodings.binary
   6 io.encodings.string io.encodings.utf8 io.streams.byte-array
   7 io.streams.string kernel math math.bitwise math.order namespaces
   8 sequences strings ;
   9
  10 IN: msgpack
  11
  12 DEFER: read-msgpack
  13
  14 <PRIVATE
  15
  16 : read-array ( n -- obj )
  17     [ read-msgpack ] replicate ;
  18
  19 : read-map ( n -- obj )
  20     2 * read-array 2 group >hashtable ;
  21
  22 : read-ext ( n -- obj )
  23     read be> [ 1 read signed-be> ] dip read 2array ;
  24
  25 PRIVATE>
  26
  27 SINGLETON: +msgpack-nil+
  28
  29 ERROR: unknown-format n ;
  30
  31 : read-msgpack ( -- obj )
  32     read1 {
  33         { [ dup 0xc0 = ] [ drop +msgpack-nil+ ] }
  34         { [ dup 0xc2 = ] [ drop f ] }
  35         { [ dup 0xc3 = ] [ drop t ] }
  36         { [ dup 0x00 0x7f between? ] [ ] }
  37         { [ dup 0xe0 mask? ] [ 1array signed-be> ] }
  38         { [ dup 0xcc = ] [ drop read1 ] }
  39         { [ dup 0xcd = ] [ drop 2 read be> ] }
  40         { [ dup 0xce = ] [ drop 4 read be> ] }
  41         { [ dup 0xcf = ] [ drop 8 read be> ] }
  42         { [ dup 0xd0 = ] [ drop 1 read signed-be> ] }
  43         { [ dup 0xd1 = ] [ drop 2 read signed-be> ] }
  44         { [ dup 0xd2 = ] [ drop 4 read signed-be> ] }
  45         { [ dup 0xd3 = ] [ drop 8 read signed-be> ] }
  46         { [ dup 0xca = ] [ drop 4 read be> bits>float ] }
  47         { [ dup 0xcb = ] [ drop 8 read be> bits>double ] }
  48         { [ dup 0xe0 mask 0xa0 = ] [ 0x1f mask read utf8 decode ] }
  49         { [ dup 0xd9 = ] [ drop read1 read utf8 decode ] }
  50         { [ dup 0xda = ] [ drop 2 read be> read utf8 decode ] }
  51         { [ dup 0xdb = ] [ drop 4 read be> read utf8 decode ] }
  52         { [ dup 0xc4 = ] [ drop read1 read B{ } like ] }
  53         { [ dup 0xc5 = ] [ drop 2 read be> read B{ } like ] }
  54         { [ dup 0xc6 = ] [ drop 4 read be> read B{ } like ] }
  55         { [ dup 0xf0 mask 0x90 = ] [ 0x0f mask read-array ] }
  56         { [ dup 0xdc = ] [ drop 2 read be> read-array ] }
  57         { [ dup 0xdd = ] [ drop 4 read be> read-array ] }
  58         { [ dup 0xf0 mask 0x80 = ] [ 0x0f mask read-map ] }
  59         { [ dup 0xde = ] [ drop 2 read be> read-map ] }
  60         { [ dup 0xdf = ] [ drop 4 read be> read-map ] }
  61         { [ dup 0xd4 = ] [ drop 1 read-ext ] }
  62         { [ dup 0xd5 = ] [ drop 2 read-ext ] }
  63         { [ dup 0xd6 = ] [ drop 4 read-ext ] }
  64         { [ dup 0xd7 = ] [ drop 8 read-ext ] }
  65         { [ dup 0xd8 = ] [ drop 16 read-ext ] }
  66         { [ dup 0xc7 = ] [ drop read1 read-ext ] }
  67         { [ dup 0xc8 = ] [ drop 2 read be> read-ext ] }
  68         { [ dup 0xc9 = ] [ drop 4 read be> read-ext ] }
  69         [ unknown-format ]
  70     } cond ;
  71
  72 ERROR: cannot-convert obj ;
  73
  74 GENERIC: write-msgpack ( obj -- )
  75
  76 <PRIVATE
  77
  78 M: +msgpack-nil+ write-msgpack drop 0xc0 write1 ;
  79
  80 M: f write-msgpack drop 0xc2 write1 ;
  81
  82 M: t write-msgpack drop 0xc3 write1 ;
  83
  84 M: integer write-msgpack
  85     dup 0 >= [
  86         {
  87             { [ dup 0x7f <= ] [ write1 ] }
  88             { [ dup 0xff <= ] [ 0xcc write1 write1 ] }
  89             { [ dup 0xffff <= ] [ 0xcd write1 2 >be write ] }
  90             { [ dup 0xffffffff <= ] [ 0xce write1 4 >be write ] }
  91             { [ dup 0xffffffffffffffff <= ] [ 0xcf write1 8 >be write ] }
  92             [ cannot-convert ]
  93         } cond
  94     ] [
  95         {
  96             { [ dup -0x1f >= ] [ write1 ] }
  97             { [ dup -0x80 >= ] [ 0xd0 write1 write1 ] }
  98             { [ dup -0x8000 >= ] [ 0xd1 write1 2 >be write ] }
  99             { [ dup -0x80000000 >= ] [ 0xd2 write1 4 >be write ] }
 100             { [ dup -0x8000000000000000 >= ] [ 0xd3 write1 8 >be write ] }
 101             [ cannot-convert ]
 102         } cond
 103     ] if ;
 104
 105 M: float write-msgpack
 106     0xcb write1 double>bits 8 >be write ;
 107
 108 M: string write-msgpack
 109     dup length {
 110         { [ dup 0x1f <= ] [ 0xa0 bitor write1 ] }
 111         { [ dup 0xff <= ] [ 0xd9 write1 write1 ] }
 112         { [ dup 0xffff <= ] [ 0xda write1 2 >be write ] }
 113         { [ dup 0xffffffff <= ] [ 0xdb write1 4 >be write ] }
 114         [ cannot-convert ]
 115     } cond output-stream get utf8 encode-string ;
 116
 117 M: byte-array write-msgpack
 118     dup length {
 119         { [ dup 0xff <= ] [ 0xc4 write1 write1 ] }
 120         { [ dup 0xffff <= ] [ 0xc5 write1 2 >be write ] }
 121         { [ dup 0xffffffff <= ] [ 0xc6 write1 4 >be write ] }
 122         [ cannot-convert ]
 123     } cond write ;
 124
 125 : write-array-header ( n -- )
 126     {
 127         { [ dup 0xf <= ] [ 0x90 bitor write1 ] }
 128         { [ dup 0xffff <= ] [ 0xdc write1 2 >be write ] }
 129         { [ dup 0xffffffff <= ] [ 0xdd write1 4 >be write ] }
 130         [ cannot-convert ]
 131     } cond ;
 132
 133 M: sequence write-msgpack
 134     dup length write-array-header [ write-msgpack ] each ;
 135
 136 : write-map-header ( n -- )
 137     {
 138         { [ dup 0xf <= ] [ 0x80 bitor write1 ] }
 139         { [ dup 0xffff <= ] [ 0xde write1 2 >be write ] }
 140         { [ dup 0xffffffff <= ] [ 0xdf write1 4 >be write ] }
 141         [ cannot-convert ]
 142     } cond ;
 143
 144 M: assoc write-msgpack
 145     dup assoc-size write-map-header
 146     [ [ write-msgpack ] bi@ ] assoc-each ;
 147
 148 PRIVATE>
 149
 150 GENERIC: msgpack> ( seq -- obj )
 151
 152 M: string msgpack>
 153     [ read-msgpack ] with-string-reader ;
 154
 155 M: byte-array msgpack>
 156     binary [ read-msgpack ] with-byte-reader ;
 157
 158 : >msgpack ( obj -- bytes )
 159     binary [ write-msgpack ] with-byte-writer ;