-
Notifications
You must be signed in to change notification settings - Fork 0
/
msgpack-in.lisp
167 lines (152 loc) · 5.36 KB
/
msgpack-in.lisp
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
(in-package cn)
;;==============================================================================
;; MSGPACK decoder
;; https://github.com/msgpack/msgpack/blob/master/spec.md
;;
;;------------------------------------------------------------------------------
(defun skip-bytes (stream count)
(dotimes (i count) (read-byte stream)))
;;==============================================================================
;; Basic stream reader *U8 and *U16 are macros
(defmacro *U8 (stream)
`(the (unsigned-byte 8) (read-byte ,stream)))
(defmacro *U16 (stream)
`(the fixnum (+ (ash (*U8 ,stream) 8)
(*U8 ,stream))))
(defun *U32 (stream)
(declare (optimize (speed 3) (debug 0) (safety 0)))
(+ (ash (*U16 stream) 16)
(*U16 stream)))
(defun *U64 (stream)
(declare (optimize (speed 3) (debug 0) (safety 0)))
(+ (ash (*U32 stream) 32)
(*U32 stream)))
;;------------------------------------------------------------------------------
;; Signed integers
;;
(defun *S8 (stream)
(let ((val (*U8 stream)))
(if (< val #x80)
val
(- val #x80))))
(defun *S16 (stream)
(let ((val (*U16 stream)))
(if (< val #x8000)
val
(- val #x8000))))
(defun *S32 (stream)
(let ((val (*U32 stream)))
(if (< val #x80000000)
val
(- val #x80000000))))
(defun *S64 (stream)
(let ((val (*U64 stream)))
(if (< val #x8000000000000000)
val
(- val #x8000000000000000))))
;;------------------------------------------------------------------------------
;;
;; DECODER
;;
;; Return TYPE and VALUE
;;
;; For integers, value is the actual decoded integer.
;;
;; For aggregate types (strings, arrays, etc), value is the number of elements
;; to follow.
;;
(defun *decode (stream)
(let ((byte (*U8 stream)))
;; (format t "BYTE ~X~&" byte)
(cond
((< byte #x80) (values 'INTEGER byte))
((< byte #x90) (values 'MAP (ldb (byte 4 0) byte)))
((< byte #xA0) (values 'ARRAY (ldb (byte 4 0) byte)))
((< byte #xC0) (values 'STRING (ldb (byte 5 0) byte)))
((< byte #xE0)
(case byte
(#xC0 (values 'NULL nil))
(#xC1 (error "Code C1"))
(#xC2 (values 'BOOLEAN nil)) ;;boolean...
(#xC3 (values 'BOOLEAN t))
(#xC4 (values 'BIN (*U8 stream))) ;; BIN8 (byte array)
(#xC5 (values 'BIN (*U16 stream)));; BIN16
(#xC6 (values 'BIN (*U32 stream)));; BIN32
(#xC7 (values 'EXT (*U8 stream)));; EXT8
(#xC8 (values 'EXT (*U16 stream)));; EXT16
(#xC9 (values 'EXT (*U32 stream)));; EXT32
(#xCA (error "FLOAT32"))
(#xCB (error "FLOAT64"))
(#xCC (values 'INTEGER (*U8 stream)))
(#xCD (values 'INTEGER (*U16 stream)))
(#xCE (values 'INTEGER (*U32 stream)))
(#xCF (values 'INTEGER (*U64 stream)))
(#xD0 (values 'INTEGER (*S8 stream)))
(#xD1 (values 'INTEGER (*S16 stream)))
(#xD2 (values 'INTEGER (*S32 stream)))
(#xD3 (values 'INTEGER(*S64 stream)))
(#xD4 (values 'EXT 1));;FIXEXT1
(#xD5 (values 'EXT 2))
(#xD6 (values 'EXT 4))
(#xD7 (values 'EXT 8))
(#xD8 (values 'EXT 16))
(#xD9 (values 'STRING (*U8 stream)))
(#xDA (values 'STRING (*U16 stream)))
(#xDB (values 'STRING (*U32 stream)))
(#xDC (values 'ARRAY (*U16 stream)))
(#xDD (values 'ARRAY (*U32 stream)))
(#xDE (values 'MAP (*U16 stream)))
(#xDF (values 'MAP (*U32 stream)))))
(t (values 'INTEGER (- (ldb (byte 5 0) byte) 32))))))
;;------------------------------------------------------------------------------
;;
;; Often we expect an aggregate object of a known type, and sometimes, of a
;; certain size. In such a case, *header is used to check the type (and
;; optionally size), and return the actual size.
(defun *header (s expected-type &optional expected-count)
(multiple-value-bind (type count) (*decode s)
(unless (eq type expected-type)
(error "~A expected; got ~A ~A" expected-type type count))
(when expected-count
(unless (= expected-count count)
(error "~A of ~A expected, but count is ~A"
expected-type expected-count count)))
count))
;;------------------------------------------------------------------------------
;; After parsing the header, make a Lisp string if you so desire:
(defun *string-data (stream size)
(let ((result (make-string size)))
(loop for i from 0 below size do
(setf (aref result i) (code-char (*U8 stream))))
result))
(defun *string (s &optional expected-count)
(*string-data s (*header s 'STRING expected-count)))
;;------------------------------------------------------------------------------
;; Array and map do not belong here, if you think about it (data types unknown)
(defun *int (s)
(multiple-value-bind (type value) (*decode s)
(unless (eq type 'INTEGER) (error "Integer expected; got ~A ~A" type value))
value))
(defun *bool (s)
(multiple-value-bind (type value) (*decode s)
(unless (or (eq type 'BOOLEAN)
(eq type 'NIL))
(error "Boolean expected; got ~A ~A" type value))
value))
;;------------------------------------------------------------------------------
;; Explorer - just read as sexps...
(defun explore (stream)
(multiple-value-bind (type value) (*decode stream)
(case type
(INTEGER value)
(STRING (*string-data stream value))
(BOOLEAN value)
(NULL value)
(ARRAY
(make-array value :initial-contents
(loop for i from 0 below value
collect (explore stream))))
(MAP
(loop for i from 0 below value
collect (cons (explore stream) (explore stream)) ))
(t (format t "UNIMPLEMENTED ~A ~A~&" type value)))))