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 (defconstant $wire-type-varint 0)
  17 (defconstant $wire-type-64bit  1)
  18 (defconstant $wire-type-string 2)
  19 (defconstant $wire-type-32bit  5)
  20
  21
  22 ;;; Serialization
  23
  24 ;; Serialize the object using the given protobuf "schema"
  25 (defun serialize-object-to-stream (object protobuf &key (stream *standard-output*) visited)
  26   "Serializes the object 'object' as a protobuf object defined in the schema 'protobuf'
  27    onto the stream 'stream' using the wire format.
  28    'visited' is a hash table used to cache object sizes. If it is supplied, it will be
  29    cleared before it is used; otherwise, a fresh table will be created.
  30    The return value is the buffer containing the serialized object. If the stream is
  31    nil, the buffer is not actually written to anywhere."
  32   (let* ((visited (let ((v (or visited (make-hash-table))))
  33                     (clrhash v)
  34                     v))
  35          (size    (object-size object protobuf :visited visited))
  36          (buffer  (make-array size :element-type '(unsigned-byte 8))))
  37     (serialize-object object protobuf buffer 0 :visited visited)
  38     (when stream
  39       (write-sequence buffer stream))
  40     buffer))
  41
  42 ;; Allow clients to add their own methods
  43 ;; This is how we address the problem of cycles, e.g. -- if you have an object
  44 ;; that may contain cycles, serialize the cyclic object using a "handle"
  45 (defgeneric serialize-object (object protobuf buffer index &key visited)
  46   (:documentation
  47    "Serializes the object 'object' as a protobuf object defined in the schema 'protobuf'
  48     into the byte array given by 'buffer' starting at the fixnum index 'index' using
  49     the wire format.
  50     'visited' is a hash table used to cache object sizes.
  51     The return value is the buffer containing the serialized object."))
  52
  53 ;; 'visited' is used to cache object sizes
  54 ;; If it's passed in explicitly, it is assumed to already have the sizes within it
  55 ;; The default method uses meta-data from the protobuf "schema"
  56 (defmethod serialize-object ((object standard-object) protobuf buffer index &key visited)
  57   (check-type protobuf (or protobuf protobuf-message))
  58   (check-type index fixnum)
  59   (check-type buffer (simple-array (unsigned-byte 8)))
  60   (let* ((class   (class-of object))
  61          (message (find-message-for-class protobuf class))
  62          (visited (or visited (make-hash-table))))
  63     (assert message ()
  64             "There is no Protobuf message for the class ~S" class)
  65     (macrolet ((read-slot (object slot reader)
  66                  ;; Don't do a boundp check, we assume the object is fully populated
  67                  ;; Unpopulated slots should be "nullable" and should contain nil
  68                  `(if ,reader
  69                     (funcall ,reader ,object)
  70                     (slot-value ,object ,slot))))
  71       (labels ((do-field (object trace field)
  72                  ;; We don't do cycle detection here
  73                  ;; If the client needs it, he can define his own 'serialize-object'
  74                  ;; method to clean things up first
  75                  (let* ((cl     (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  76                         (slot   (proto-value field))
  77                         (reader (proto-reader field))
  78                         msg)
  79                    (cond ((eq (proto-required field) :repeated)
  80                           (cond ((and slot (proto-packed field) (packed-type-p cl))
  81                                  (setq index (serialize-packed (read-slot object slot reader)
  82                                                                cl field buffer index)))
  83                                 ((and slot (keywordp cl))
  84                                  (map () #'(lambda (v)
  85                                              (when (or v (eq cl :bool))
  86                                                (setq index (serialize-prim v cl field buffer index))))
  87                                          (read-slot object slot reader)))
  88                                 ((typep (setq msg (and cl (loop for p in trace
  89                                                                 thereis (or (find-message-for-class p cl)
  90                                                                             (find-enum-for-type p cl)))))
  91                                         'protobuf-message)
  92                                  (dolist (v (if slot (read-slot object slot reader) (list object)))
  93                                    ;; To serialize an embedded message, first say that it's
  94                                    ;; a string, then encode its size, then serialize its fields
  95                                    (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
  96                                          (len (object-size v protobuf :visited visited)))
  97                                      (setq index (encode-uint32 tag buffer index))
  98                                      (setq index (encode-uint32 len buffer index)))
  99                                    (map () (curry #'do-field v (cons msg trace))
 100                                            (proto-fields msg))))
 101                                 ((and slot (typep msg 'protobuf-enum))
 102                                  (map () #'(lambda (v)
 103                                              (when v
 104                                                (setq index (serialize-enum v msg field buffer index))))
 105                                          (read-slot object slot reader)))))
 106                          (t
 107                           (cond ((and slot (keywordp cl))
 108                                  (let ((v (read-slot object slot reader)))
 109                                    (when (or v (eq cl :bool))
 110                                      (setq index (serialize-prim v cl field buffer index)))))
 111                                 ((typep (setq msg (and cl (loop for p in trace
 112                                                                 thereis (or (find-message-for-class p cl)
 113                                                                             (find-enum-for-type p cl)))))
 114                                         'protobuf-message)
 115                                  (let ((v (if slot (read-slot object slot reader) object)))
 116                                    (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 117                                          (len (object-size v protobuf :visited visited)))
 118                                      (setq index (encode-uint32 tag buffer index))
 119                                      (setq index (encode-uint32 len buffer index)))
 120                                    (when v
 121                                      (map () (curry #'do-field v (cons msg trace))
 122                                              (proto-fields msg)))))
 123                                 ((and slot (typep msg 'protobuf-enum))
 124                                  (let ((v (read-slot object slot reader)))
 125                                    (when v
 126                                      (setq index (serialize-enum v msg field buffer index)))))))))))
 127         (declare (dynamic-extent #'do-field))
 128         (map () (curry #'do-field object (list message protobuf)) (proto-fields message))))))
 129
 130
 131 ;;; Deserialization
 132
 133 (defun deserialize-object-from-stream (class protobuf &key (stream *standard-input*))
 134   "Deserializes an object of the give class 'class' as a protobuf object defined
 135    in the schema 'protobuf' from the stream 'stream' using the wire format.
 136    The return value is the object."
 137   (let* ((size    (file-length stream))
 138          (buffer  (make-array size :element-type '(unsigned-byte 8))))
 139     (read-sequence buffer stream)
 140     (deserialize-object class protobuf buffer 0)))
 141
 142 ;; Allow clients to add their own methods
 143 ;; This is you might preserve object identity, e.g.
 144 (defgeneric deserialize-object (class protobuf buffer index)
 145   (:documentation
 146    "Deserializes an object of the given class 'class' as a protobuf object defined
 147     in the schema 'protobuf' from the byte array given by 'buffer' starting at
 148     the fixnum index 'index' using the wire format.
 149     The return value is the object."))
 150
 151 ;; The default method uses meta-data from the protobuf "schema"
 152 ;; Note that 'class' is the Lisp name of the Protobufs message (class)
 153 ;; It is not the name of any overriding class ('proto-class-override')
 154 (defmethod deserialize-object ((class symbol) protobuf buffer index)
 155   (check-type protobuf (or protobuf protobuf-message))
 156   (check-type index fixnum)
 157   (check-type buffer (simple-array (unsigned-byte 8)))
 158   (let ((length (length buffer)))
 159     (labels ((deserialize (class trace &optional (end length))
 160                (let* ((message (loop for p in trace
 161                                      thereis (or (find-message-for-class p class)
 162                                                  (find-enum-for-type p class))))
 163                       (object  (make-instance (or (proto-class-override message) class))))
 164                  (assert (eql (proto-class message) class) ()
 165                          "The class in message ~S does not match the Lisp class ~S"
 166                          (proto-class message) class)
 167                  (assert message ()
 168                          "There is no Protobuf message for the class ~S" class)
 169                  (loop
 170                    (when (>= index end)
 171                      (return-from deserialize object))
 172                    (multiple-value-bind (val idx)
 173                        (decode-uint32 buffer index)
 174                      (setq index idx)
 175                      (let* ((type  (logand val #x7))
 176                             (fld   (logand (ash val -3) #x1FFFFFFF))
 177                             (field (find fld (proto-fields message) :key #'proto-index))
 178                             (cl    (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 179                             ;; It's OK for this to be null
 180                             ;; That means we're parsing some version of a message
 181                             ;; that has the field, but our current message does not
 182                             ;; We still have to deserialize everything, though
 183                             (slot  (proto-value field))
 184                             msg)
 185                        ;;--- Check for mismatched types, running past end of buffer, etc
 186                        (declare (ignore type))
 187                        (cond ((eq (proto-required field) :repeated)
 188                               (cond ((and (proto-packed field) (packed-type-p cl))
 189                                      (multiple-value-bind (values idx)
 190                                          (deserialize-packed cl field buffer index)
 191                                        (setq index idx)
 192                                        (when slot
 193                                          (setf (slot-value object slot) values))))
 194                                     ((keywordp cl)
 195                                      (multiple-value-bind (val idx)
 196                                          (deserialize-prim cl field buffer index)
 197                                        (setq index idx)
 198                                        (when slot
 199                                          (setf (slot-value object slot)
 200                                                (nconc (slot-value object slot) (list val))))))
 201                                     ((typep (setq msg (and cl (or (find-message-for-class protobuf cl)
 202                                                                   (find-enum-for-type protobuf cl))))
 203                                             'protobuf-message)
 204                                      (multiple-value-bind (len idx)
 205                                          (decode-uint32 buffer index)
 206                                        (setq index idx)
 207                                        (let ((obj (deserialize cl (cons msg trace) (+ index len))))
 208                                          (when slot
 209                                            (setf (slot-value object slot)
 210                                                  (nconc (slot-value object slot) (list obj)))))))
 211                                     ((typep msg 'protobuf-enum)
 212                                      (multiple-value-bind (val idx)
 213                                          (deserialize-enum msg field buffer index)
 214                                        (setq index idx)
 215                                        (when slot
 216                                          (setf (slot-value object slot)
 217                                                (nconc (slot-value object slot) (list val))))))))
 218                              (t
 219                               (cond ((keywordp cl)
 220                                      (multiple-value-bind (val idx)
 221                                          (deserialize-prim cl field buffer index)
 222                                        (setq index idx)
 223                                        (when slot
 224                                          (setf (slot-value object slot) val))))
 225                                     ((typep (setq msg (and cl (or (find-message-for-class protobuf cl)
 226                                                                   (find-enum-for-type protobuf cl))))
 227                                             'protobuf-message)
 228                                      (multiple-value-bind (len idx)
 229                                          (decode-uint32 buffer index)
 230                                        (setq index idx)
 231                                        (let ((obj (deserialize cl (cons msg trace) (+ index len))))
 232                                          (when slot
 233                                            (setf (slot-value object slot) obj)))))
 234                                     ((typep msg 'protobuf-enum)
 235                                      (multiple-value-bind (val idx)
 236                                          (deserialize-enum msg field buffer index)
 237                                        (setq index idx)
 238                                        (when slot
 239                                          (setf (slot-value object slot) val)))))))))))))
 240       (declare (dynamic-extent #'deserialize))
 241       (deserialize class (list protobuf)))))
 242
 243
 244 ;;; Object sizes
 245
 246 ;; Allow clients to add their own methods
 247 ;; This is how we address the problem of cycles, e.g. -- if you have an object
 248 ;; that may contain cycles, return the size of the "handle" to the object
 249 (defgeneric object-size (object protobuf &key visited)
 250   (:documentation
 251    "Computes the size in bytes of the object 'object' defined in the schema 'protobuf'.
 252     'visited' is a hash table used to cache object sizes.
 253     The return value is the size of the object in bytes."))
 254
 255 ;; 'visited' is used to cache object sizes
 256 ;; The default method uses meta-data from the protobuf "schema"
 257 (defmethod object-size ((object standard-object) protobuf &key visited)
 258   (check-type protobuf (or protobuf protobuf-message))
 259   (let ((size (and visited (gethash object visited))))
 260     (when size
 261       (return-from object-size size)))
 262   (let* ((class   (class-of object))
 263          (message (find-message-for-class protobuf class))
 264          (size    0))
 265     (assert message ()
 266             "There is no Protobuf message for the class ~S" class)
 267     (macrolet ((read-slot (object slot reader)
 268                  ;; Don't do a boundp check, we assume the object is fully populated
 269                  ;; Unpopulated slots should be "nullable" and should contain nil
 270                  `(if ,reader
 271                     (funcall ,reader ,object)
 272                     (slot-value ,object ,slot))))
 273       (labels ((do-field (object trace field)
 274                  ;; We don't do cycle detection here
 275                  ;; If the client needs it, he can define his own 'object-size'
 276                  ;; method to clean things up first
 277                  (let* ((cl     (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 278                         (slot   (proto-value field))
 279                         (reader (proto-reader field))
 280                         msg)
 281                    (cond ((eq (proto-required field) :repeated)
 282                           (cond ((and slot (proto-packed field) (packed-type-p cl))
 283                                  (iincf size (packed-size (read-slot object slot reader) cl field)))
 284                                 ((and slot (keywordp cl))
 285                                  (map () #'(lambda (v)
 286                                              (when (or v (eq cl :bool))
 287                                                (iincf size (prim-size v cl field))))
 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 (ilogior $wire-type-string (iash (proto-index field) 3)))
 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                                 ((and slot (typep msg 'protobuf-enum))
 301                                  (map () #'(lambda (v)
 302                                              (when v
 303                                                (iincf size (enum-size v msg field))))
 304                                          (read-slot object slot reader)))))
 305                          (t
 306                           (cond ((and slot (keywordp cl))
 307                                  (let ((v (read-slot object slot reader)))
 308                                    (when (or v (eq cl :bool))
 309                                      (iincf size (prim-size v cl field)))))
 310                                 ((typep (setq msg (and cl (loop for p in trace
 311                                                                 thereis (or (find-message-for-class p cl)
 312                                                                             (find-enum-for-type p cl)))))
 313                                         'protobuf-message)
 314                                  (let ((v (if slot (read-slot object slot reader) object)))
 315                                    (when v
 316                                      (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 317                                            (len (object-size v protobuf :visited visited)))
 318                                        (iincf size (length32 tag))
 319                                        (iincf size (length32 len)))
 320                                      (map () (curry #'do-field v (cons msg trace))
 321                                              (proto-fields msg)))))
 322                                 ((and slot (typep msg 'protobuf-enum))
 323                                  (let ((v (read-slot object slot reader)))
 324                                    (when v
 325                                      (iincf size (enum-size (read-slot object slot reader) msg field)))))))))))
 326         (declare (dynamic-extent #'do-field))
 327         (map () (curry #'do-field object (list message protobuf)) (proto-fields message))
 328         (when visited
 329           (setf (gethash object visited) size))   ;cache the size
 330         size))))