]> asedeno.scripts.mit.edu Git - cl-protobufs.git/blob - serialize.lisp
ba274cd03ccb07d0873a7862f6ee4338d58aa9c2
[cl-protobufs.git] / serialize.lisp
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;;                                                                  ;;;
3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
4 ;;;                                                                  ;;;
5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
6 ;;;                                                                  ;;;
7 ;;; Original author: Scott McKay                                     ;;;
8 ;;;                                                                  ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
11 (in-package "PROTO-IMPL")
12
13
14 ;;; Protobuf serialization from Lisp objects
15
16 ;;; Serialization
17
18 ;; Serialize the object using the given protobuf "schema"
19 (defun serialize-object-to-stream (object protobuf &key (stream *standard-output*) visited)
20   "Serializes the object 'object' as a protobuf object defined in the schema 'protobuf'
21    onto the stream 'stream' using the wire format.
22    'visited' is a hash table used to cache object sizes. If it is supplied, it will be
23    cleared before it is used; otherwise, a fresh table will be created.
24    The return value is the buffer containing the serialized object. If the stream is
25    nil, the buffer is not actually written to anywhere."
26   (let* ((visited (let ((v (or visited (make-hash-table))))
27                     (clrhash v)
28                     v))
29          (size    (object-size object protobuf :visited visited))
30          (buffer  (make-array size :element-type '(unsigned-byte 8))))
31     (serialize-object object protobuf buffer 0 :visited visited)
32     (when stream
33       (write-sequence buffer stream))
34     buffer))
35
36 ;; Allow clients to add their own methods
37 ;; This is how we address the problem of cycles, e.g. -- if you have an object
38 ;; that may contain cycles, serialize the cyclic object using a "handle"
39 (defgeneric serialize-object (object protobuf buffer index &key visited)
40   (:documentation
41    "Serializes the object 'object' as a protobuf object defined in the schema 'protobuf'
42     into the byte array given by 'buffer' starting at the fixnum index 'index' using
43     the wire format.
44     'visited' is a hash table used to cache object sizes.
45     The return value is the buffer containing the serialized object."))
46
47 ;; 'visited' is used to cache object sizes
48 ;; If it's passed in explicitly, it is assumed to already have the sizes within it
49 ;; The default method uses meta-data from the protobuf "schema"
50 (defmethod serialize-object ((object standard-object) protobuf buffer index &key visited)
51   (check-type protobuf (or protobuf protobuf-message))
52   (check-type index fixnum)
53   (check-type buffer (simple-array (unsigned-byte 8)))
54   (let* ((class   (class-of object))
55          (message (find-message-for-class protobuf class))
56          (visited (or visited (make-hash-table))))
57     (assert message ()
58             "There is no Protobuf message for the class ~S" class)
59     (macrolet ((read-slot (object slot reader)
60                  ;; Don't do a boundp check, we assume the object is fully populated
61                  ;; Unpopulated slots should be "nullable" and should contain nil
62                  `(if ,reader
63                     (funcall ,reader ,object)
64                     (slot-value ,object ,slot))))
65       (labels ((do-field (object trace field)
66                  ;; We don't do cycle detection here
67                  ;; If the client needs it, he can define his own 'serialize-object'
68                  ;; method to clean things up first
69                  (let* ((cl     (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
70                         (slot   (proto-value field))
71                         (reader (proto-reader field))
72                         msg)
73                    (when (or slot reader)
74                      (cond ((eq (proto-required field) :repeated)
75                             (cond ((and (proto-packed field) (packed-type-p cl))
76                                    (let ((tag (make-tag cl (proto-index field))))
77                                      (setq index (serialize-packed (read-slot object slot reader)
78                                                                    cl tag buffer index))))
79                                   ((keywordp cl)
80                                    (let ((tag (make-tag cl (proto-index field))))
81                                      (map () #'(lambda (v)
82                                                  (setq index (serialize-prim v cl tag buffer index)))
83                                              (read-slot object slot reader))))
84                                   ((typep (setq msg (and cl (loop for p in trace
85                                                                   thereis (or (find-message-for-class p cl)
86                                                                               (find-enum-for-type p cl)))))
87                                           'protobuf-message)
88                                    (dolist (v (if slot (read-slot object slot reader) (list object)))
89                                      ;; To serialize an embedded message, first say that it's
90                                      ;; a string, then encode its size, then serialize its fields
91                                      (let ((tag (make-tag $wire-type-string (proto-index field)))
92                                            (len (object-size v protobuf :visited visited)))
93                                        (setq index (encode-uint32 tag buffer index))
94                                        (setq index (encode-uint32 len buffer index)))
95                                      (map () (curry #'do-field v (cons msg trace))
96                                              (proto-fields msg))))
97                                   ((typep msg 'protobuf-enum)
98                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
99                                      (map () #'(lambda (v)
100                                                  (setq index (serialize-enum v (proto-values msg) tag buffer index)))
101                                              (read-slot object slot reader))))))
102                            (t
103                             (cond ((keywordp cl)
104                                    (let ((v (read-slot object slot reader)))
105                                      (when (or v (eq cl :bool))
106                                        (let ((tag (make-tag cl (proto-index field))))
107                                          (setq index (serialize-prim v cl tag buffer index))))))
108                                   ((typep (setq msg (and cl (loop for p in trace
109                                                                   thereis (or (find-message-for-class p cl)
110                                                                               (find-enum-for-type p cl)))))
111                                           'protobuf-message)
112                                    (let ((v (if slot (read-slot object slot reader) object)))
113                                      (let ((tag (make-tag $wire-type-string (proto-index field)))
114                                            (len (object-size v protobuf :visited visited)))
115                                        (setq index (encode-uint32 tag buffer index))
116                                        (setq index (encode-uint32 len buffer index)))
117                                      (when v
118                                        (map () (curry #'do-field v (cons msg trace))
119                                                (proto-fields msg)))))
120                                   ((typep msg 'protobuf-enum)
121                                    (let ((v (read-slot object slot reader)))
122                                      (when v
123                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
124                                          (setq index (serialize-enum v (proto-values msg) tag buffer index)))))))))))))
125         (declare (dynamic-extent #'do-field))
126         (map () (curry #'do-field object (list message protobuf)) (proto-fields message))))))
127
128
129 ;;; Deserialization
130
131 (defun deserialize-object-from-stream (class protobuf &key (stream *standard-input*))
132   "Deserializes an object of the give class 'class' as a protobuf object defined
133    in the schema 'protobuf' from the stream 'stream' using the wire format.
134    The return value is the object."
135   (let* ((size    (file-length stream))
136          (buffer  (make-array size :element-type '(unsigned-byte 8))))
137     (read-sequence buffer stream)
138     (deserialize-object class protobuf buffer 0)))
139
140 ;; Allow clients to add their own methods
141 ;; This is you might preserve object identity, e.g.
142 (defgeneric deserialize-object (class protobuf buffer index)
143   (:documentation
144    "Deserializes an object of the given class 'class' as a protobuf object defined
145     in the schema 'protobuf' from the byte array given by 'buffer' starting at
146     the fixnum index 'index' using the wire format.
147     The return value is the object."))
148
149 ;; The default method uses meta-data from the protobuf "schema"
150 ;; Note that 'class' is the Lisp name of the Protobufs message (class)
151 ;; It is not the name of any overriding class ('proto-class-override')
152 (defmethod deserialize-object ((class symbol) protobuf buffer index)
153   (check-type protobuf (or protobuf protobuf-message))
154   (check-type index fixnum)
155   (check-type buffer (simple-array (unsigned-byte 8)))
156   (let ((length (length buffer)))
157     (labels ((deserialize (class trace &optional (end length))
158                (let* ((message (loop for p in trace
159                                      thereis (or (find-message-for-class p class)
160                                                  (find-enum-for-type p class))))
161                       (object  (make-instance (or (proto-class-override message) class))))
162                  (assert (eql (proto-class message) class) ()
163                          "The class in message ~S does not match the Lisp class ~S"
164                          (proto-class message) class)
165                  (assert message ()
166                          "There is no Protobuf message for the class ~S" class)
167                  (loop
168                    (when (>= index end)
169                      (return-from deserialize object))
170                    (multiple-value-bind (val idx)
171                        (decode-uint32 buffer index)
172                      (setq index idx)
173                      (let* ((type  (logand val #x7))
174                             (fld   (logand (ash val -3) #x1FFFFFFF))
175                             (field (find fld (proto-fields message) :key #'proto-index))
176                             (cl    (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
177                             ;; It's OK for this to be null
178                             ;; That means we're parsing some version of a message
179                             ;; that has the field, but our current message does not
180                             ;; We still have to deserialize everything, though
181                             (slot  (proto-value field))
182                             msg)
183                        ;;--- Check for mismatched types, running past end of buffer, etc
184                        (declare (ignore type))
185                        (cond ((eq (proto-required field) :repeated)
186                               (cond ((and (proto-packed field) (packed-type-p cl))
187                                      (multiple-value-bind (values idx)
188                                          (deserialize-packed cl buffer index)
189                                        (setq index idx)
190                                        (when slot
191                                          (setf (slot-value object slot) values))))
192                                     ((keywordp cl)
193                                      (multiple-value-bind (val idx)
194                                          (deserialize-prim cl buffer index)
195                                        (setq index idx)
196                                        (when slot
197                                          (setf (slot-value object slot)
198                                                (nconc (slot-value object slot) (list val))))))
199                                     ((typep (setq msg (and cl (or (find-message-for-class protobuf cl)
200                                                                   (find-enum-for-type protobuf cl))))
201                                             'protobuf-message)
202                                      (multiple-value-bind (len idx)
203                                          (decode-uint32 buffer index)
204                                        (setq index idx)
205                                        (let ((obj (deserialize cl (cons msg trace) (+ index len))))
206                                          (when slot
207                                            (setf (slot-value object slot)
208                                                  (nconc (slot-value object slot) (list obj)))))))
209                                     ((typep msg 'protobuf-enum)
210                                      (multiple-value-bind (val idx)
211                                          (deserialize-enum (proto-values msg) buffer index)
212                                        (setq index idx)
213                                        (when slot
214                                          (setf (slot-value object slot)
215                                                (nconc (slot-value object slot) (list val))))))))
216                              (t
217                               (cond ((keywordp cl)
218                                      (multiple-value-bind (val idx)
219                                          (deserialize-prim cl buffer index)
220                                        (setq index idx)
221                                        (when slot
222                                          (setf (slot-value object slot) val))))
223                                     ((typep (setq msg (and cl (or (find-message-for-class protobuf cl)
224                                                                   (find-enum-for-type protobuf cl))))
225                                             'protobuf-message)
226                                      (multiple-value-bind (len idx)
227                                          (decode-uint32 buffer index)
228                                        (setq index idx)
229                                        (let ((obj (deserialize cl (cons msg trace) (+ index len))))
230                                          (when slot
231                                            (setf (slot-value object slot) obj)))))
232                                     ((typep msg 'protobuf-enum)
233                                      (multiple-value-bind (val idx)
234                                          (deserialize-enum (proto-values msg) buffer index)
235                                        (setq index idx)
236                                        (when slot
237                                          (setf (slot-value object slot) val)))))))))))))
238       (declare (dynamic-extent #'deserialize))
239       (deserialize class (list protobuf)))))
240
241
242 ;;; Object sizes
243
244 ;; Allow clients to add their own methods
245 ;; This is how we address the problem of cycles, e.g. -- if you have an object
246 ;; that may contain cycles, return the size of the "handle" to the object
247 (defgeneric object-size (object protobuf &key visited)
248   (:documentation
249    "Computes the size in bytes of the object 'object' defined in the schema 'protobuf'.
250     'visited' is a hash table used to cache object sizes.
251     The return value is the size of the object in bytes."))
252
253 ;; 'visited' is used to cache object sizes
254 ;; The default method uses meta-data from the protobuf "schema"
255 (defmethod object-size ((object standard-object) protobuf &key visited)
256   (check-type protobuf (or protobuf protobuf-message))
257   (let ((size (and visited (gethash object visited))))
258     (when size
259       (return-from object-size size)))
260   (let* ((class   (class-of object))
261          (message (find-message-for-class protobuf class))
262          (size    0))
263     (assert message ()
264             "There is no Protobuf message for the class ~S" class)
265     (macrolet ((read-slot (object slot reader)
266                  ;; Don't do a boundp check, we assume the object is fully populated
267                  ;; Unpopulated slots should be "nullable" and should contain nil
268                  `(if ,reader
269                     (funcall ,reader ,object)
270                     (slot-value ,object ,slot))))
271       (labels ((do-field (object trace field)
272                  ;; We don't do cycle detection here
273                  ;; If the client needs it, he can define his own 'object-size'
274                  ;; method to clean things up first
275                  (let* ((cl     (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
276                         (slot   (proto-value field))
277                         (reader (proto-reader field))
278                         msg)
279                    (when (or slot reader)
280                      (cond ((eq (proto-required field) :repeated)
281                             (cond ((and (proto-packed field) (packed-type-p cl))
282                                    (let ((tag (make-tag cl (proto-index field))))
283                                      (iincf size (packed-size (read-slot object slot reader) cl tag))))
284                                   ((keywordp cl)
285                                    (let ((tag (make-tag cl (proto-index field))))
286                                      (map () #'(lambda (v)
287                                                  (iincf size (prim-size v cl tag)))
288                                              (read-slot object slot reader))))
289                                   ((typep (setq msg (and cl (loop for p in trace
290                                                                   thereis (or (find-message-for-class p cl)
291                                                                               (find-enum-for-type p cl)))))
292                                           'protobuf-message)
293                                    (dolist (v (if slot (read-slot object slot reader) (list object)))
294                                      (let ((tag (make-tag $wire-type-string (proto-index field)))
295                                            (len (object-size v protobuf :visited visited)))
296                                        (iincf size (length32 tag))
297                                        (iincf size (length32 len)))
298                                      (map () (curry #'do-field v (cons msg trace))
299                                              (proto-fields msg))))
300                                   ((typep msg 'protobuf-enum)
301                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
302                                      (map () #'(lambda (v)
303                                                  (iincf size (enum-size v (proto-values msg) tag)))
304                                              (read-slot object slot reader))))))
305                            (t
306                             (cond ((keywordp cl)
307                                    (let ((v (read-slot object slot reader)))
308                                      (when (or v (eq cl :bool))
309                                        (let ((tag (make-tag cl (proto-index field))))
310                                          (iincf size (prim-size v cl tag))))))
311                                   ((typep (setq msg (and cl (loop for p in trace
312                                                                   thereis (or (find-message-for-class p cl)
313                                                                               (find-enum-for-type p cl)))))
314                                           'protobuf-message)
315                                    (let ((v (if slot (read-slot object slot reader) object)))
316                                      (when v
317                                        (let ((tag (make-tag $wire-type-string (proto-index field)))
318                                              (len (object-size v protobuf :visited visited)))
319                                          (iincf size (length32 tag))
320                                          (iincf size (length32 len)))
321                                        (map () (curry #'do-field v (cons msg trace))
322                                                (proto-fields msg)))))
323                                   ((typep msg 'protobuf-enum)
324                                    (let ((v (read-slot object slot reader)))
325                                      (when v
326                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
327                                          (iincf size (enum-size (read-slot object slot reader) (proto-values msg) tag)))))))))))))
328         (declare (dynamic-extent #'do-field))
329         (map () (curry #'do-field object (list message protobuf)) (proto-fields message))
330         (when visited
331           (setf (gethash object visited) size))   ;cache the size
332         size))))
333
334 \f
335 ;;; Compile-time generation of serializers
336
337 (defun generate-serializer (message protobuf
338                             &optional (vobj 'object) (vproto 'protobuf)
339                                       (vbuf 'buffer) (vidx 'buffer-index))
340   "Generate a 'serialize-object' method for the given message."
341   (with-collectors ((serializers collect-serializer))
342     (dolist (field (proto-fields message))
343       (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
344              (msg    (and class (not (keywordp class))
345                           (or (or (find-message-for-class message class)
346                                   (find-enum-for-type message class))
347                               (or (find-message-for-class protobuf class)
348                                   (find-enum-for-type protobuf class)))))
349              ;; Don't do a boundp check, we assume the object is fully populated
350              ;; Unpopulated slots should be "nullable" and should contain nil
351              (reader (cond ((proto-reader field)
352                             `(funcall #',(proto-reader field) ,vobj))
353                            ((proto-value field)
354                             `(slot-value ,vobj ',(proto-value field)))))
355              (index  (proto-index field)))
356         (when reader
357           (cond ((eq (proto-required field) :repeated)
358                  (cond ((and (proto-packed field) (packed-type-p class))
359                         (collect-serializer
360                          (let ((tag (make-tag class (proto-index field))))
361                            `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx)))))
362                        ((keywordp class)
363                         (collect-serializer
364                          (let ((tag (make-tag class (proto-index field))))
365                            `(dolist (,vobj ,reader)
366                               (setq ,vidx (serialize-prim ,vobj ,class ,tag ,vbuf ,vidx))))))
367                        ((typep msg 'protobuf-message)
368                         ;; To serialize an embedded message, first say that it's
369                         ;; a string, then encode its size, then serialize its fields
370                         (collect-serializer
371                          (let ((tag (make-tag $wire-type-string index)))
372                            `(dolist (,vobj ,reader)
373                               (let ((len (object-size ,vobj ,vproto :visited visited)))
374                                 (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
375                                 (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
376                                 (serialize-object ,vobj ,vproto ,vbuf ,vidx :visited visited)
377                                 (incf ,vidx len))))))
378                        ((typep msg 'protobuf-enum)
379                         (collect-serializer
380                          (let ((tag (make-tag $wire-type-varint index)))
381                            `(dolist (,vobj ,reader)
382                               (setq ,vidx (serialize-enum ,vobj '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))))))
383                 (t
384                  (cond ((keywordp class)
385                         (collect-serializer
386                          (let ((tag (make-tag class (proto-index field))))
387                            (if (eq class :bool)
388                              `(let ((,vobj ,reader))
389                                 (setq ,vidx (serialize-prim ,vobj ,class ,tag ,vbuf ,vidx)))
390                              `(let ((,vobj ,reader))
391                                 (when ,vobj
392                                   (setq ,vidx (serialize-prim ,vobj ,class ,tag ,vbuf ,vidx))))))))
393                        ((typep msg 'protobuf-message)
394                         (collect-serializer
395                          (let ((tag (make-tag $wire-type-string index)))
396                            `(let ((,vobj ,reader))
397                               (when ,vobj
398                                 (let ((len (object-size ,vobj ,vproto :visited visited)))
399                                   (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
400                                   (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
401                                   (serialize-object ,vobj ,vproto ,vbuf ,vidx :visited visited)
402                                   (incf ,vidx len)))))))
403                        ((typep msg 'protobuf-enum)
404                         (collect-serializer
405                          (let ((tag (make-tag $wire-type-varint index)))
406                            `(let ((,vobj ,reader))
407                               (when ,vobj
408                                 (setq ,vidx (serialize-enum ,vobj '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))))))))
409     `(defmethod serialize-object ((,vobj ,(proto-class message)) ,vproto ,vbuf ,vidx &key visited) 
410        (declare (ignorable visited))
411       ,@serializers
412        (values ,vbuf ,vidx))))
413
414 #+++NOTYET      ;---*** DO THIS
415 (defun generate-deserializer (message protobuf
416                               &optional (vclass 'class) (vproto 'protobuf)
417                                         (vbuf 'buffer) (vidx 'buffer-index))
418   "Generate a 'deserialize-object' method for the given message."
419   )
420
421 (defun generate-object-size (message protobuf
422                              &optional (vobj 'object) (vproto 'protobuf)
423                                        (vsize 'size))
424   "Generate an 'object-size' method for the given message."
425   (with-collectors ((serializers collect-serializer))
426     (dolist (field (proto-fields message))
427       (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
428              (msg    (and class (not (keywordp class))
429                           (or (or (find-message-for-class message class)
430                                   (find-enum-for-type message class))
431                               (or (find-message-for-class protobuf class)
432                                   (find-enum-for-type protobuf class)))))
433              (reader (cond ((proto-reader field)
434                             `(funcall #',(proto-reader field) ,vobj))
435                            ((proto-value field)
436                             `(slot-value ,vobj ',(proto-value field)))))
437              (index  (proto-index field)))
438         (when reader
439           (cond ((eq (proto-required field) :repeated)
440                  (cond ((and (proto-packed field) (packed-type-p class))
441                         (collect-serializer
442                          (let ((tag (make-tag class (proto-index field))))
443                            `(iincf ,vsize (packed-size ,reader ,class ,tag)))))
444                        ((keywordp class)
445                         (collect-serializer
446                          (let ((tag (make-tag class (proto-index field))))
447                            `(dolist (,vobj ,reader)
448                               (iincf ,vsize (prim-size ,vobj ,class ,tag))))))
449                        ((typep msg 'protobuf-message)
450                         (collect-serializer
451                          (let ((tag (make-tag $wire-type-string index)))
452                            `(dolist (,vobj ,reader)
453                               (let ((len (object-size ,vobj ,vproto :visited visited)))
454                                 (iincf ,vsize (length32 ,tag))
455                                 (iincf ,vsize (length32 len))
456                                 (iincf ,vsize len))))))
457                        ((typep msg 'protobuf-enum)
458                         (let ((tag (make-tag $wire-type-varint index)))
459                           (collect-serializer
460                            `(dolist (,vobj ,reader)
461                               (iincf ,vsize (enum-size ,vobj '(,@(proto-values msg)) ,tag))))))))
462                 (t
463                  (cond ((keywordp class)
464                         (let ((tag (make-tag class (proto-index field))))
465                           (collect-serializer
466                            (if (eq class :bool)
467                              `(let ((,vobj ,reader))
468                                 (iincf ,vsize (prim-size ,vobj ,class ,tag)))
469                              `(let ((,vobj ,reader))
470                                 (when ,vobj
471                                   (iincf ,vsize (prim-size ,vobj ,class ,tag))))))))
472                        ((typep msg 'protobuf-message)
473                         (collect-serializer
474                          (let ((tag (make-tag $wire-type-string index)))
475                            `(let ((,vobj ,reader))
476                               (when ,vobj
477                                 (let ((len (object-size ,vobj ,vproto :visited visited)))
478                                   (iincf ,vsize (length32 ,tag))
479                                   (iincf ,vsize (length32 len))
480                                   (iincf ,vsize len)))))))
481                        ((typep msg 'protobuf-enum)
482                         (let ((tag (make-tag $wire-type-varint index)))
483                           (collect-serializer
484                            `(let ((,vobj ,reader))
485                               (when ,vobj
486                                 (iincf ,vsize (enum-size ,vobj '(,@(proto-values msg)) ,tag)))))))))))))
487     `(defmethod  object-size ((,vobj ,(proto-class message)) ,vproto &key visited)
488        (let ((,vsize (and visited (gethash object visited))))
489          (when ,vsize
490            (return-from object-size ,vsize)))
491        (let ((,vsize 0))
492          ,@serializers
493          ,vsize))))