1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Confidential and proprietary information of ITA Software, Inc. ;;;
5 ;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protocol buffers wire format
18 ;; Serialize 'val' of primitive type 'type' into the buffer
19 (defun serialize-prim (val type field buffer index)
20 "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
21 The value is given by 'val', the primitive type by 'type'.
22 'field' is the protobuf-field describing the value.
23 Modifies the buffer in place, and returns the new index into the buffer."
24 (declare (type fixnum index)
25 (type (simple-array (unsigned-byte 8)) buffer))
26 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
29 (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
30 (idx (encode-uint32 tag buffer index)))
31 (declare (type fixnum tag idx))
32 (encode-uint32 val buffer idx)))
34 (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
35 (idx (encode-uint32 tag buffer index)))
36 (declare (type fixnum tag idx))
37 (encode-uint64 val buffer idx)))
39 (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
40 (idx (encode-uint32 tag buffer index)))
41 (declare (type fixnum tag idx))
42 (encode-uint32 (zig-zag-encode32 val) buffer idx)))
44 (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
45 (idx (encode-uint32 tag buffer index)))
46 (declare (type fixnum tag idx))
47 (encode-uint64 (zig-zag-encode64 val) buffer idx)))
49 (let* ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3)))
50 (idx (encode-uint32 tag buffer index)))
51 (declare (type fixnum tag idx))
52 ;;---*** Shouldn't this always be writing 4 bytes?
53 (encode-uint32 val buffer idx)))
55 (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
56 (idx (encode-uint32 tag buffer index)))
57 (declare (type fixnum tag idx))
58 ;;---*** Shouldn't this always be writing 8 bytes?
59 (encode-uint64 val buffer idx)))
61 (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
62 (idx (encode-uint32 tag buffer index)))
63 (declare (type fixnum tag idx))
64 (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
66 (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
67 (idx (encode-uint32 tag buffer index)))
68 (declare (type fixnum tag idx))
69 (encode-octets val buffer idx)))
71 (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
72 (idx (encode-uint32 tag buffer index)))
73 (declare (type fixnum tag idx))
74 (encode-uint32 (if val 1 0) buffer idx)))
76 (let* ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3)))
77 (idx (encode-uint32 tag buffer index)))
78 (declare (type fixnum tag idx))
79 (encode-single val buffer idx)))
81 (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
82 (idx (encode-uint32 tag buffer index)))
83 (declare (type fixnum tag idx))
84 (encode-double val buffer idx)))
85 ;; A few of our homegrown types
87 (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
88 (idx (encode-uint32 tag buffer index))
89 (val (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val))))
90 ;; Call 'string' in case we are trying to serialize a symbol name
91 (declare (type fixnum tag idx))
92 (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
93 ((:date :time :datetime :timestamp)
94 (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
95 (idx (encode-uint32 tag buffer index)))
96 (declare (type fixnum tag idx))
97 (encode-uint64 val buffer idx))))))
99 (defun serialize-packed (values type field buffer index)
100 "Serializes a set of packed values into the buffer at the given index.
101 The values are given by 'values', the primitive type by 'type'.
102 'field' is the protobuf-field describing the value.
103 Modifies the buffer in place, and returns the new index into the buffer."
104 (declare (type fixnum index)
105 (type (simple-array (unsigned-byte 8)) buffer))
106 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
107 (let* ((wtype (ecase type
108 ((:int32 :int64) $wire-type-varint)
109 ((:uint32 :uint64) $wire-type-varint)
110 ((:sint32 :sint64) $wire-type-varint)
111 ((:fixed32 :sfixed32) $wire-type-32bit)
112 ((:fixed64 :sfixed64) $wire-type-64bit)
113 ((:float) $wire-type-32bit)
114 ((:double) $wire-type-64bit)))
115 (tag (ilogior wtype (iash (proto-index field) 3)))
116 (idx (encode-uint32 tag buffer index)))
117 (declare (type fixnum wtype tag idx))
118 (multiple-value-bind (full-len len)
119 (packed-size values type field)
120 (declare (type fixnum len) (ignore full-len))
121 (setq idx (encode-uint32 len buffer idx)))
124 (dolist (val values idx)
125 (setq idx (encode-uint32 val buffer idx))))
127 (dolist (val values idx)
128 (setq idx (encode-uint64 val buffer idx))))
130 (dolist (val values idx)
131 (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))))
133 (dolist (val values idx)
134 (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))))
135 ((:fixed32 :sfixed32)
136 (dolist (val values idx)
137 (setq idx (encode-uint32 val buffer idx))))
138 ((:fixed64 :sfixed64)
139 (dolist (val values idx)
140 (setq idx (encode-uint64 val buffer idx))))
142 (dolist (val values idx)
143 (setq idx (encode-single val buffer idx))))
145 (dolist (val values idx)
146 (setq idx (encode-double val buffer idx))))))))
148 ;; Serialize 'val' of enum type 'type' into the buffer
149 (defun serialize-enum (val enum field buffer index)
150 "Serializes a Protobufs enum value into the buffer at the given index.
151 The value is given by 'val', the enum type by 'enum'.
152 'field' is the protobuf-field describing the value.
153 Modifies the buffer in place, and returns the new index into the buffer."
154 (declare (type fixnum index)
155 (type (simple-array (unsigned-byte 8)) buffer))
156 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
157 (let* ((val (let ((e (find val (proto-values enum) :key #'proto-value)))
158 (and e (proto-index e))))
159 (tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
160 (idx (encode-uint32 tag buffer index)))
161 (declare (type fixnum val tag idx))
162 (encode-uint32 val buffer idx))))
167 ;; Deserialize the next object of type 'type', described by the protobuf field 'field'
168 (defun deserialize-prim (type field buffer index)
169 "Deserializes the next object of primitive type 'type', described by the protobuf-field 'field'.
170 Deserializes from the byte vector 'buffer' starting at 'index'.
171 Returns the value and and the new index into the buffer."
172 (declare (type fixnum index)
173 (type (simple-array (unsigned-byte 8)) buffer))
174 (declare (ignore field))
175 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
178 (decode-uint32 buffer index))
180 (decode-uint64 buffer index))
182 (multiple-value-bind (val idx)
183 (decode-uint32 buffer index)
184 (values (zig-zag-decode32 val) idx)))
186 (multiple-value-bind (val idx)
187 (decode-uint64 buffer index)
188 (values (zig-zag-decode64 val) idx)))
189 ((:fixed32 :sfixed32)
190 ;;---*** Shouldn't this always be reading 4 bytes?
191 (decode-uint32 buffer index))
192 ((:fixed64 :sfixed64)
193 ;;---*** Shouldn't this always be reading 8 bytes?
194 (decode-uint64 buffer index))
196 (multiple-value-bind (val idx)
197 (decode-octets buffer index)
198 (values (babel:octets-to-string val :encoding :utf-8) idx)))
200 (decode-octets buffer index))
202 (multiple-value-bind (val idx)
203 (decode-uint32 buffer index)
204 (values (if (zerop val) nil t) idx)))
206 (decode-single buffer index))
208 (decode-double buffer index))
209 ;; A few of our homegrown types
211 (multiple-value-bind (val idx)
212 (decode-octets buffer index)
213 (let* ((val (babel:octets-to-string val :encoding :utf-8))
214 (colon (position #\: val))
215 (pkg (subseq val 0 colon))
216 (sym (subseq val (i+ colon 1))))
217 (values (intern sym pkg) idx))))
218 ((:date :time :datetime :timestamp)
219 (decode-uint64 buffer index)))))
221 (defun deserialize-packed (type field buffer index)
222 "Deserializes the next packed values of type 'type', described by the protobuf-field 'field'.
223 Deserializes from the byte vector 'buffer' starting at 'index'.
224 Returns the value and and the new index into the buffer."
225 (declare (type fixnum index)
226 (type (simple-array (unsigned-byte 8)) buffer))
227 (declare (ignore field))
228 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
229 (multiple-value-bind (len idx)
230 (decode-uint32 buffer index)
231 (declare (type fixnum len idx))
232 (let ((end (i+ idx len)))
233 (declare (type fixnum end))
234 (with-collectors ((values collect-value))
237 (return-from deserialize-packed (values values idx)))
238 (multiple-value-bind (val nidx)
241 (decode-uint32 buffer idx))
243 (decode-uint64 buffer idx))
245 (multiple-value-bind (val idx)
246 (decode-uint32 buffer idx)
247 (values (zig-zag-decode32 val) idx)))
249 (multiple-value-bind (val idx)
250 (decode-uint64 buffer idx)
251 (values (zig-zag-decode64 val) idx)))
252 ((:fixed32 :sfixed32)
253 (decode-uint32 buffer idx))
254 ((:fixed64 :sfixed64)
255 (decode-uint64 buffer idx))
257 (decode-single buffer idx))
259 (decode-double buffer idx)))
261 (setq idx nidx))))))))
263 (defun deserialize-enum (enum field buffer index)
264 "Deserializes the next enum of type 'type', described by the protobuf-field 'field'.
265 Deserializes from the byte vector 'buffer' starting at 'index'.
266 Returns the value and and the new index into the buffer."
267 (declare (type fixnum index)
268 (type (simple-array (unsigned-byte 8)) buffer))
269 (declare (ignore field))
270 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
271 (multiple-value-bind (val idx)
272 (decode-uint32 buffer index)
273 (let ((val (let ((e (find val (proto-values enum) :key #'proto-index)))
274 (and e (proto-value e)))))
280 (defun prim-size (val type field)
281 "Returns the size in bytes that the primitive object will take when serialized."
282 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
285 (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
286 (i+ (length32 tag) (length32 val))))
288 (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
289 (i+ (length32 tag) (length64 val))))
291 (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
292 (i+ (length32 tag) (length32 (zig-zag-encode32 val)))))
294 (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
295 (i+ (length32 tag) (length64 (zig-zag-encode64 val)))))
296 ((:fixed32 :sfixed32)
297 (let ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3))))
298 (i+ (length32 tag) 4)))
299 ((:fixed64 :sfixed64)
300 (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
301 (i+ (length32 tag) 8)))
303 (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
304 (len (babel:string-size-in-octets val :encoding :utf-8)))
305 (i+ (length32 tag) (length32 len) len)))
307 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
308 (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
310 (i+ (length32 tag) (length32 len) len))))
312 (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
313 (i+ (length32 tag) 1)))
315 (let ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3))))
316 (i+ (length32 tag) 4)))
318 (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
319 (i+ (length32 tag) 8)))
320 ;; A few of our homegrown types
322 (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
323 (len (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val)))))
324 (i+ (length32 tag) (length32 len) len)))
325 ((:date :time :datetime :timestamp)
326 (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
327 (i+ (length32 tag) 8))))))
329 (defun packed-size (values type field)
330 "Returns the size in bytes that the packed object will take when serialized."
331 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
332 (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
333 (len (loop for val in values
335 ((:int32 :uint32) (length32 val))
336 ((:int64 :uint64) (length64 val))
337 ((:sint32) (length32 (zig-zag-encode32 val)))
338 ((:sint64) (length64 (zig-zag-encode64 val)))
339 ((:fixed32 :sfixed32) 4)
340 ((:fixed64 :sfixed64) 8)
343 (declare (type fixnum tag len))
344 ;; Two value: the full size of the packed object, and the size
345 ;; of just the payload
346 (values (i+ (length32 tag) (length32 len) len) len))))
348 (defun enum-size (val enum field)
349 "Returns the size in bytes that the enum object will take when serialized."
350 (let ((val (let ((e (find val (proto-values enum) :key #'proto-value)))
351 (and e (proto-index e))))
352 (tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
353 (i+ (length32 tag) (length32 val))))
358 (defun encode-uint32 (val buffer index)
359 "Encodes the 32-bit integer 'val' into the buffer at the given index.
360 Modifies the buffer, and returns the new index into the buffer."
361 (declare (type fixnum index)
362 (type (simple-array (unsigned-byte 8)) buffer))
363 (assert (< val #.(ash 1 32)) ()
364 "The value ~D is longer than 32 bits" val)
365 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
366 ;; Seven bits at a time, least significant bits first
367 (loop do (let ((bits (ldb #.(byte 7 0) val)))
368 (declare (type fixnum bits))
369 (setq val (ash val -7))
370 (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
373 (values index buffer)) ;return the buffer to improve 'trace'
375 (defun encode-uint64 (val buffer index)
376 "Encodes the 64-bit integer 'val' into the buffer at the given index.
377 Modifies the buffer, and returns the new index into the buffer."
378 (declare (type fixnum index)
379 (type (simple-array (unsigned-byte 8)) buffer))
380 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
381 (loop do (let ((bits (ldb #.(byte 7 0) val)))
382 (declare (type fixnum bits))
383 (setq val (ash val -7))
384 (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
387 (values index buffer))
389 (defun encode-single (val buffer index)
390 "Encodes the single float 'val' into the buffer at the given index.
391 Modifies the buffer, and returns the new index into the buffer."
392 (declare (type fixnum index)
393 (type (simple-array (unsigned-byte 8)) buffer))
394 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
395 (let ((bits (single-float-bits val)))
397 (let ((byte (ldb #.(byte 8 0) bits)))
398 (declare (type fixnum byte))
399 (setq bits (ash bits -8))
400 (setf (aref buffer index) byte)
402 (values index buffer))
404 (defun encode-double (val buffer index)
405 "Encodes the double float 'val' into the buffer at the given index.
406 Modifies the buffer, and returns the new index into the buffer."
407 (declare (type fixnum index)
408 (type (simple-array (unsigned-byte 8)) buffer))
409 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
410 (multiple-value-bind (low high)
411 (double-float-bits val)
413 (let ((byte (ldb #.(byte 8 0) low)))
414 (declare (type fixnum byte))
415 (setq low (ash low -8))
416 (setf (aref buffer index) byte)
419 (let ((byte (ldb #.(byte 8 0) high)))
420 (declare (type fixnum byte))
421 (setq high (ash high -8))
422 (setf (aref buffer index) byte)
424 (values index buffer))
426 (defun encode-octets (octets buffer index)
427 "Encodes the octets into the buffer at the given index.
428 Modifies the buffer, and returns the new index into the buffer."
429 (declare (type fixnum index)
430 (type (simple-array (unsigned-byte 8)) buffer))
431 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
432 (let* ((len (length octets))
433 (idx (encode-uint32 len buffer index)))
434 (declare (type fixnum len idx))
435 (replace buffer octets :start1 idx)
436 (values (i+ idx len) buffer))))
438 (defun zig-zag-encode32 (val)
439 (assert (< (integer-length val) 32))
440 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
441 (logxor (ash val 1) (ash val -31))))
443 (defun zig-zag-encode64 (val)
444 (assert (< (integer-length val) 64))
445 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
446 (logxor (ash val 1) (ash val -63))))
451 ;; Decode the value from the buffer at the given index,
452 ;; then return the value and new index into the buffer
453 (defun decode-uint32 (buffer index)
454 "Decodes the next 32-bit integer in the buffer at the given index.
455 Returns both the decoded value and the new index into the buffer."
456 (declare (type fixnum index)
457 (type (simple-array (unsigned-byte 8)) buffer))
458 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
459 ;; Seven bits at a time, least significant bits first
461 for places fixnum upfrom 0 by 7
462 for byte fixnum = (prog1 (aref buffer index) (iincf index))
463 do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
466 (assert (< val #.(ash 1 32)) ()
467 "The value ~D is longer than 32 bits" val)
468 (return (values val index))))))
470 (defun decode-uint64 (buffer index)
471 "Decodes the next 64-bit integer in the buffer at the given index.
472 Returns both the decoded value and the new index into the buffer."
473 (declare (type fixnum index)
474 (type (simple-array (unsigned-byte 8)) buffer))
475 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
476 ;; Seven bits at a time, least significant bits first
478 for places fixnum upfrom 0 by 7
479 for byte fixnum = (prog1 (aref buffer index) (iincf index))
480 do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
482 finally (return (values val index)))))
484 (defun decode-single (buffer index)
485 "Decodes the next single float in the buffer at the given index.
486 Returns both the decoded value and the new index into the buffer."
487 (declare (type fixnum index)
488 (type (simple-array (unsigned-byte 8)) buffer))
489 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
490 ;; Eight bits at a time, least significant bits first
493 for places fixnum upfrom 0 by 8
494 for byte fixnum = (prog1 (aref buffer index) (iincf index))
495 do (setq bits (logior bits (ash byte places))))
496 (when (i= (ldb #.(byte 1 31) bits) 1) ;sign bit set, so negative value
497 (decf bits #.(ash 1 32)))
498 (values (make-single-float bits) index))))
500 (defun decode-double (buffer index)
501 "Decodes the next double float in the buffer at the given index.
502 Returns both the decoded value and the new index into the buffer."
503 (declare (type fixnum index)
504 (type (simple-array (unsigned-byte 8)) buffer))
505 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
506 ;; Eight bits at a time, least significant bits first
510 for places fixnum upfrom 0 by 8
511 for byte fixnum = (prog1 (aref buffer index) (iincf index))
512 do (setq low (logior low (ash byte places))))
514 for places fixnum upfrom 0 by 8
515 for byte fixnum = (prog1 (aref buffer index) (iincf index))
516 do (setq high (logior high (ash byte places))))
517 ;; High bits are signed, but low bits are unsigned
518 (when (i= (ldb #.(byte 1 31) high) 1) ;sign bit set, so negative value
519 (decf high #.(ash 1 32)))
520 (values (make-double-float low high) index))))
522 (defun decode-octets (buffer index)
523 "Decodes the next octets in the buffer at the given index.
524 Returns both the decoded value and the new index into the buffer."
525 (declare (type fixnum index)
526 (type (simple-array (unsigned-byte 8)) buffer))
527 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
528 (multiple-value-bind (len idx)
529 (decode-uint32 buffer index)
530 (declare (type fixnum len idx))
531 (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
533 (defun zig-zag-decode32 (val)
534 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
535 (logxor (ash val -1) (- (logand val 1)))))
537 (defun zig-zag-decode64 (val)
538 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
539 (logxor (ash val -1) (- (logand val 1)))))
544 (defun length32 (val)
545 "Returns the length that 'val' will take when encoded as a 32-bit integer."
546 (assert (< val #.(ash 1 32)) ()
547 "The value ~D is longer than 32 bits" val)
548 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
550 (declare (type fixnum size))
552 (setq val (ash val -7))
557 (defun length64 (val)
558 "Returns the length that 'val' will take when encoded as a 64-bit integer."
559 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
561 (declare (type fixnum size))
563 (setq val (ash val -7))