-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathmsgpack-imple.scm
525 lines (485 loc) · 22.1 KB
/
msgpack-imple.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
;;;;; msgpack-imple.scm - MessagePack scheme implementation
;;
;; Copyright (c) 2013, Hugo Arregui
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; 3. The name of the authors may not be used to endorse or promote products
;; derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(use srfi-69 byte-blob numbers srfi-1 matchable)
(include "flonum-utils.scm")
;; limits
(define fixed_uint_limit 127)
(define uint8_limit (sub1 (expt 2 8)))
(define uint16_limit (sub1 (expt 2 16)))
(define uint32_limit (sub1 (expt 2 32)))
(define uint64_limit (sub1 (expt 2 64)))
(define fixed_int_limit -32)
(define int8_limit (sub1 (- (expt 2 7))))
(define int16_limit (sub1 (- (expt 2 15))))
(define int32_limit (sub1 (- (expt 2 31))))
(define int64_limit (sub1 (- (expt 2 63))))
(define int64_maxlimit (sub1 (expt 2 63)))
(define fixed_raw_limit 31) ;in bytes
(define raw8_limit (sub1 (expt 2 8)))
(define raw16_limit (sub1 (expt 2 16)))
(define raw32_limit (sub1 (expt 2 32)))
(define fixed_array_limit 15) ;in bytes
(define array16_limit (sub1 (expt 2 16)))
(define array32_limit (sub1 (expt 2 32)))
(define fixed_map_limit 15) ;in bytes
(define map16_limit (sub1 (expt 2 16)))
(define map32_limit (sub1 (expt 2 32)))
;; constants
(define constants '((() . #xc0)
(#t . #xc3)
(#f . #xc2)
(uint8 . #xcc)
(uint16 . #xcd)
(uint32 . #xce)
(uint64 . #xcf)
(int8 . #xd0)
(int16 . #xd1)
(int32 . #xd2)
(int64 . #xd3)
(str8 . #xd9)
(str16 . #xda)
(str32 . #xdb)
(bin8 . #xc4)
(bin16 . #xc5)
(bin32 . #xc6)
(float . #xca)
(double . #xcb)
(array16 . #xdc)
(array32 . #xdd)
(map16 . #xde)
(map32 . #xdf)
(ext8 . #xc7)
(ext16 . #xc8)
(ext32 . #xc9)
(fixext1 . #xd4)
(fixext2 . #xd5)
(fixext4 . #xd6)
(fixext8 . #xd7)
(fixext16 . #xd8)))
(define-record extension type data)
(define make-extension
(let ((old-make-extension make-extension))
(lambda (type data)
(if (or (not (integer? type))
(< type 0)
(> type 127))
(error (format "invalid type ~A, it should be a number between 0 and 127" type)))
(if (not (byte-blob? data))
(error (format "invalid data ~A, it should be a byte-blob" data)))
(old-make-extension type data))))
(define constant-repr-map (alist->hash-table constants))
(define repr-constant-map
(alist->hash-table (map (lambda (entry)
(cons (cdr entry) (car entry))) constants)))
(define (read-byte/eof-error port)
(let ((b (read-byte port)))
(if (eof-object? b)
(error "premature eof")
b)))
;; byte manipulation primitives
(define (byte-complement2 n)
(add1 (- 255 n)))
(define (get-smallest-byte n)
(bitwise-and #xff n))
(define (write-bytes port value size)
(if (> size 0)
(let* ((shift_size (- size 1))
(byte (get-smallest-byte (arithmetic-shift value (- (* 8 shift_size))))))
(write-byte byte port)
(write-bytes port value shift_size))))
(define (read-bytes* port size)
(map
(lambda (e)
(read-byte/eof-error port))
(iota size)))
(define (bytes->number bytes f)
(let* ((size (length bytes)))
(apply bitwise-ior
(map
(lambda (byte shift_size)
(arithmetic-shift (f byte) shift_size))
bytes
(iota size (* (sub1 size) 8) -8)))))
(define write-uint write-bytes)
(define (read-uint port size #!optional (mapper identity))
(mapper (bytes->number (read-bytes* port size) identity)))
(define write-sint write-bytes)
(define (read-sint port size #!optional (mapper identity))
(let ((bytes (read-bytes* port size)))
(mapper
(if (bit-set? (car bytes) 7) ; its negative
(- (add1 (bytes->number bytes (cut - 255 <>))))
(bytes->number bytes identity)))))
(define (write-raw port blob size)
(assert (byte-blob? blob) "write-raw: expected byte-blob" blob)
(let loop ((index 0))
(if (< index size)
(let ((byte (byte-blob-uref blob index)))
(write-byte byte port)
(loop (+ index 1))))))
(define (read-raw port size #!optional (mapper identity))
(let loop ((size size)
(data (byte-blob-empty)))
(if (> size 0)
(let ((byte (read-byte/eof-error port)))
(loop (- size 1) (byte-blob-cons byte data)))
(mapper (byte-blob-reverse data)))))
(define (write-array port value size)
(assert (= (vector-length value) size) "write-array: invalid size" size)
(let loop ((index 0))
(when (< index size)
(pack port (vector-ref value index))
(loop (+ index 1)))))
(define (write-map port value size)
(assert (hash-table? value) "write-map: expected hash-table" value)
(hash-table-walk value (lambda (k v)
(pack port k)
(pack port v))))
(define (write-header port type)
(let ((header (hash-table-ref constant-repr-map type)))
(write-byte header port)))
(define (fixed-uint? value)
(= (bitwise-and #x80 value) 0))
(define (fixed-sint? value)
(= (bitwise-and #xe0 value) #xe0))
(define (fixed-str? value)
(= (bitwise-and #xe0 value) #xa0))
(define (fixed-array? value)
(= (bitwise-and #xf0 value) #x90))
(define (fixed-map? value)
(= (bitwise-and #xf0 value) #x80))
;;
(define (out-of-limit-error type value)
(error type "Out of limit" value))
(define Uint
(let* ((lowrite
(lambda (port value header size)
(write-header port header)
(write-uint port value size)))
(read-uint
read-uint)
(pack
(lambda (port value)
(if (or (not (integer? value))
(< value 0))
(error 'badInput "cannot pack value as uint" value))
(cond ((<= value fixed_uint_limit)
(let ((header (bitwise-and value #x7f)))
(write-byte header port)))
((<= value uint8_limit) (lowrite port value 'uint8 1))
((<= value uint16_limit) (lowrite port value 'uint16 2))
((<= value uint32_limit) (lowrite port value 'uint32 4))
((<= value uint64_limit) (lowrite port value 'uint64 8))
(#t (out-of-limit-error 'uint value))))))
(match-lambda*
(('unpack 'uint8) (cut read-uint <> 1 <>)) ; port mapper
(('unpack 'uint16) (cut read-uint <> 2 <>))
(('unpack 'uint32) (cut read-uint <> 4 <>))
(('unpack 'uint64) (cut read-uint <> 8 <>))
(('unpack 'fixed) (lambda (port value mapper)
(mapper value)))
(('pack) pack))))
(define Sint
(let* ((lowrite
(lambda (port value header size)
(write-header port header)
(write-sint port value size)))
(read-sint
read-sint)
(pack
(lambda (port value)
(if (not (integer? value))
(error 'badInput "cannot pack value as sint" value))
(cond ((> value int64_maxlimit)
(out-of-limit-error 'sint value))
((> value 0)
((Uint 'pack) port value))
((>= value fixed_int_limit)
(let ((header (bitwise-ior #xe0 (get-smallest-byte value))))
(write-byte header port)))
((>= value int8_limit) (lowrite port value 'int8 1))
((>= value int16_limit) (lowrite port value 'int16 2))
((>= value int32_limit) (lowrite port value 'int32 4))
((>= value int64_limit) (lowrite port value 'int64 8))
(#t (out-of-limit-error 'sint value))))))
(match-lambda*
(('unpack 'int8) (cut read-sint <> 1 <>)) ; port mapper
(('unpack 'int16) (cut read-sint <> 2 <>))
(('unpack 'int32) (cut read-sint <> 4 <>))
(('unpack 'int64) (cut read-sint <> 8 <>))
(('unpack 'fixed) (lambda (port value mapper)
(mapper (- (byte-complement2 value)))))
(('pack) pack))))
(define Float
(let* ((write-float
(lambda (port value)
(write-uint port (float->uint32 value) 4)))
(read-float
(lambda (port #!optional (mapper identity))
(mapper (byte-blob->float (byte-blob-reverse (read-raw port 4))))))
(pack
(lambda (port value)
(write-header port 'float)
(write-float port value))))
(match-lambda
('unpack read-float)
('pack pack))))
(define Double
(let* ((write-double
(lambda (port value)
(write-raw port (double->byte-blob value) 8)))
(read-double
(lambda (port #!optional (mapper identity))
(mapper (byte-blob->double (byte-blob-reverse (read-raw port 8))))))
(pack
(lambda (port value)
(write-header port 'double)
(write-double port value))))
(match-lambda
('unpack read-double)
('pack pack))))
(define Array
(let* ((lowrite
(lambda (port value header header-size size)
(write-header port header)
(write-uint port size header-size)
(write-array port value size)))
(read-array
(lambda (port size #!optional (mapper identity))
(define array (make-vector size))
(let loop ((index 0))
(when (< index size)
(vector-set! array index (unpack port mapper))
(loop (+ index 1))))
(mapper array)))
(pack
(lambda (port value)
(if (not (vector? value))
(error 'badInput "cannot pack value as array" value))
(let ((size (vector-length value)))
(cond ((<= size fixed_array_limit)
(let ((header (bitwise-ior #x90 size)))
(write-byte header port)
(write-array port value size)))
((<= size array16_limit) (lowrite port value 'array16 2 size))
((<= size array32_limit) (lowrite port value 'array32 4 size))
(#t (out-of-limit-error 'array value)))))))
(match-lambda*
(('unpack 'array16) (lambda (port mapper) (read-array port (read-uint port 2) mapper)))
(('unpack 'array32) (lambda (port mapper) (read-array port (read-uint port 4) mapper)))
(('unpack 'fixed) (lambda (port value mapper)
(let ((size (bitwise-and #x0f value)))
(read-array port size mapper))))
(('pack) pack))))
(define Map
(let* ((lowrite
(lambda (port value header header-size size)
(write-header port header)
(write-uint port size header-size)
(write-map port value size)))
(read-map
(lambda (port size #!optional (mapper identity))
(define table (make-hash-table #:size size))
(let loop ((size size))
(if (> size 0)
(let* ((k (unpack port mapper))
(v (unpack port mapper)))
(hash-table-set! table k v)
(loop (- size 1)))))
(mapper table)))
(pack
(lambda (port value)
(if (not (hash-table? value))
(error 'badInput "cannot pack value as map" value))
(let ((size (hash-table-size value)))
(cond ((<= size fixed_map_limit)
(let ((header (bitwise-ior #x80 size)))
(write-byte header port)
(write-map port value size)))
((<= size map16_limit) (lowrite port value 'map16 2 size))
((<= size map32_limit) (lowrite port value 'map32 4 size))
(#t (out-of-limit-error 'map value)))))))
(match-lambda*
(('unpack 'map16) (lambda (port mapper) (read-map port (read-uint port 2) mapper)))
(('unpack 'map32) (lambda (port mapper) (read-map port (read-uint port 4) mapper)))
(('unpack 'fixed) (lambda (port value mapper)
(let ((size (bitwise-and #x0f value)))
(read-map port size mapper))))
(('pack) pack))))
(define Str
(let* ((lowrite
(lambda (port value header header-size size)
(write-header port header)
(write-uint port size header-size)
(write-raw port value size)))
(read-str
(lambda (port size #!optional (mapper identity))
(mapper (read-raw port size byte-blob->string))))
(pack
(lambda (port value)
(if (not (string? value))
(error 'badInput "cannot pack value as str" value))
(let* ((blob (string->byte-blob value))
(size (byte-blob-length blob)))
(cond ((<= size fixed_raw_limit)
(let ((header (bitwise-ior #xa0 size)))
(write-byte header port)
(write-raw port blob size)))
((<= size raw8_limit) (lowrite port blob 'str8 1 size))
((<= size raw16_limit) (lowrite port blob 'str16 2 size))
((<= size raw32_limit) (lowrite port blob 'str32 4 size))
(#t (out-of-limit-error 'str value)))))))
(match-lambda*
(('unpack 'str8) (lambda (port mapper) (read-str port (read-uint port 1) mapper)))
(('unpack 'str16) (lambda (port mapper) (read-str port (read-uint port 2) mapper)))
(('unpack 'str32) (lambda (port mapper) (read-str port (read-uint port 4) mapper)))
(('unpack 'fixed) (lambda (port value mapper)
(let ((size (bitwise-and #x1f value)))
(read-str port size mapper))))
(('pack) pack))))
(define Bin
(let* ((lowrite
(lambda (port value header header-size size)
(write-header port header)
(write-uint port size header-size)
(write-raw port value size)))
(read-bin
read-raw)
(pack
(lambda (port value)
(if (not (byte-blob? value))
(error 'badInput "cannot pack value as bin" value))
(let ((size (byte-blob-length value)))
(cond
((<= size raw8_limit) (lowrite port value 'bin8 1 size))
((<= size raw16_limit) (lowrite port value 'bin16 2 size))
((<= size raw32_limit) (lowrite port value 'bin32 4 size))
(#t (out-of-limit-error 'bin value)))))))
(match-lambda*
(('unpack 'bin8) (lambda (port mapper) (read-bin port (read-uint port 1) mapper)))
(('unpack 'bin16) (lambda (port mapper) (read-bin port (read-uint port 2) mapper)))
(('unpack 'bin32) (lambda (port mapper) (read-bin port (read-uint port 4) mapper)))
(('pack) pack))))
(define Ext
(let* ((lowrite
(lambda (port header type data header-size size)
(write-header port header)
(if header-size
(write-uint port size header-size))
(write-sint port type 1)
(write-raw port data size)))
(read-ext
(lambda (port size mapper)
(let* ((type (read-sint port 1))
(data (read-raw port size)))
(mapper (make-extension type data)))))
(pack (lambda (port value)
(if (not (extension? value))
(error 'badInput "cannot pack value as extension " value))
(let* ((type (extension-type value))
(data (extension-data value))
(size (byte-blob-length data)))
(cond
((<= size 1) (lowrite port 'fixext1 type data #f 1))
((<= size 2) (lowrite port 'fixext2 type data #f 2))
((<= size 4) (lowrite port 'fixext4 type data #f 4))
((<= size 8) (lowrite port 'fixext8 type data #f 8))
((<= size 16) (lowrite port 'fixext16 type data #f 16))
((<= size raw8_limit) (lowrite port 'ext8 type data 1 size))
((<= size raw16_limit) (lowrite port 'ext16 type data 2 size))
((<= size raw32_limit) (lowrite port 'ext32 type data 4 size))
(#t (out-of-limit-error 'ext value)))))))
(match-lambda*
(('unpack 'fixext1) (lambda (port mapper) (read-ext port 1 mapper)))
(('unpack 'fixext2) (lambda (port mapper) (read-ext port 2 mapper)))
(('unpack 'fixext4) (lambda (port mapper) (read-ext port 4 mapper)))
(('unpack 'fixext8) (lambda (port mapper) (read-ext port 8 mapper)))
(('unpack 'fixext16) (lambda (port mapper) (read-ext port 16 mapper)))
(('unpack 'ext8) (lambda (port mapper) (read-ext port (read-uint port 1) mapper)))
(('unpack 'ext16) (lambda (port mapper) (read-ext port (read-uint port 2) mapper)))
(('unpack 'ext32) (lambda (port mapper) (read-ext port (read-uint port 4) mapper)))
(('pack) pack))))
(define pack-uint (Uint 'pack))
(define pack-sint (Sint 'pack))
(define pack-float (Float 'pack))
(define pack-double (Double 'pack))
(define pack-array (Array 'pack))
(define pack-map (Map 'pack))
(define pack-bin (Bin 'pack))
(define pack-str (Str 'pack))
(define pack-ext (Ext 'pack))
(define (pack port value)
(let ((repr/or-false (hash-table-ref/default constant-repr-map value #f)))
(cond (repr/or-false
(write-byte repr/or-false port))
((char? value)
(pack-uint port (char->integer value)))
((integer? value)
((if (>= value 0) pack-uint pack-sint) port value))
((flonum? value)
(pack-double port value))
((blob? value)
(pack-bin port (blob->byte-blob value)))
((byte-blob? value)
(pack-bin port value))
((string? value)
(pack-str port value))
((extension? value)
(pack-ext port value))
((list? value)
(pack-array port (list->vector value)))
((vector? value)
(pack-array port value))
((hash-table? value)
(pack-map port value))
(#t
(error (format "I don't know how to handle: ~A" value))))))
(define (unpack port #!optional (mapper identity))
(let ((value (read-byte port)))
(if (eof-object? value)
value
(cond ((hash-table-exists? repr-constant-map value)
(let ((constant (hash-table-ref repr-constant-map value)))
(match constant
((or 'uint8 'uint16 'uint32 'uint64) ((Uint 'unpack constant) port mapper))
((or 'int8 'int16 'int32 'int64) ((Sint 'unpack constant) port mapper))
((or 'str8 'str16 'str32) ((Str 'unpack constant) port mapper))
((or 'bin8 'bin16 'bin32) ((Bin 'unpack constant) port mapper))
((or 'array16 'array32) ((Array 'unpack constant) port mapper))
((or 'map16 'map32) ((Map 'unpack constant) port mapper))
((or 'ext8 'ext16 'ext32
'fixext1 'fixext2 'fixext4
'fixext8 'fixext16) ((Ext 'unpack constant) port mapper))
('float ((Float 'unpack) port mapper))
('double ((Double 'unpack) port mapper))
(else (mapper constant)))))
((fixed-uint? value) ((Uint 'unpack 'fixed) port value mapper))
((fixed-sint? value) ((Sint 'unpack 'fixed) port value mapper))
((fixed-str? value) ((Str 'unpack 'fixed) port value mapper))
((fixed-array? value) ((Array 'unpack 'fixed) port value mapper))
((fixed-map? value) ((Map 'unpack 'fixed) port value mapper))
(#t (error 'unpack "cannot unpack" value))))))