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     (labels ((safe-slot-value (object slot)
  66                (if (slot-boundp object slot)
  67                  (slot-value object slot)
  68                  nil))
  69              (do-field (object trace field)
  70                ;; We don't do cycle detection here
  71                ;; If the client needs it, he can define his own 'serialize-object'
  72                ;; method to clean things up first
  73                (let* ((cl  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  74                       (msg (and cl (loop for p in trace
  75                                          thereis (or (find-message-for-class p cl)
  76                                                      (find-enum-for-type p cl)))))
  77                       (slot (proto-value field)))
  78                  (cond ((eq (proto-required field) :repeated)
  79                         (cond ((and slot (proto-packed field) (packed-type-p cl))
  80                                (setq index (serialize-packed (safe-slot-value object slot) cl field buffer index)))
  81                               ((and slot (keywordp cl))
  82                                (map () #'(lambda (v)
  83                                            (when (or (eq cl :bool) (not (null v)))
  84                                              (setq index (serialize-prim v cl field buffer index))))
  85                                        (safe-slot-value object slot)))
  86                               ((and slot (typep msg 'protobuf-enum))
  87                                (map () #'(lambda (v)
  88                                            (when (not (null v))
  89                                              (setq index (serialize-enum v msg field buffer index))))
  90                                        (safe-slot-value object slot)))
  91                               ((typep msg 'protobuf-message)
  92                                (dolist (v (if slot (safe-slot-value object slot) (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                        (t
 102                         (cond ((and slot (keywordp cl))
 103                                (let ((v (safe-slot-value object slot)))
 104                                  (when (or (eq cl :bool) (not (null v)))
 105                                    (setq index (serialize-prim v cl field buffer index)))))
 106                               ((and slot (typep msg 'protobuf-enum))
 107                                (let ((v (safe-slot-value object slot)))
 108                                  (when (not (null v))
 109                                    (setq index (serialize-enum v msg field buffer index)))))
 110                               ((typep msg 'protobuf-message)
 111                                (let ((v (if slot (safe-slot-value object slot) object)))
 112                                  (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 113                                        (len (object-size v protobuf :visited visited)))
 114                                    (setq index (encode-uint32 tag buffer index))
 115                                    (setq index (encode-uint32 len buffer index)))
 116                                  (when (not (null v))
 117                                    (map () (curry #'do-field v (cons msg trace))
 118                                            (proto-fields msg)))))))))))
 119       (map () (curry #'do-field object (list message protobuf)) (proto-fields message)))))
 120
 121
 122 ;;; Deserialization
 123
 124 (defun deserialize-object-from-stream (class protobuf &key (stream *standard-input*))
 125   "Deserializes an object of the give class 'class' as a protobuf object defined
 126    in the schema 'protobuf' from the stream 'stream' using the wire format.
 127    The return value is the object."
 128   (let* ((size    (file-length stream))
 129          (buffer  (make-array size :element-type '(unsigned-byte 8))))
 130     (read-sequence buffer stream)
 131     (deserialize-object class protobuf buffer 0)))
 132
 133 ;; Allow clients to add their own methods
 134 ;; This is you might preserve object identity, e.g.
 135 (defgeneric deserialize-object (class protobuf buffer index)
 136   (:documentation
 137    "Deserializes an object of the give class 'class' as a protobuf object defined
 138     in the schema 'protobuf' from the byte array given by 'buffer' starting at
 139     the fixnum index 'index' using the wire format.
 140     The return value is the object."))
 141
 142 ;; The default method uses meta-data from the protobuf "schema"
 143 (defmethod deserialize-object ((class symbol) protobuf buffer index)
 144   (check-type protobuf (or protobuf protobuf-message))
 145   (check-type index fixnum)
 146   (check-type buffer (simple-array (unsigned-byte 8)))
 147   (let ((length (length buffer)))
 148     (labels ((deserialize (class trace &optional (end length))
 149                (let ((object  (make-instance class))
 150                      (message (loop for p in trace
 151                                     thereis (or (find-message-for-class p class)
 152                                                 (find-enum-for-type p class)))))
 153                  (assert message ()
 154                          "There is no Protobuf message for the class ~S" class)
 155                  (loop
 156                    (when (>= index end)
 157                      (return-from deserialize object))
 158                    (multiple-value-bind (val idx)
 159                        (decode-uint32 buffer index)
 160                      (setq index idx)
 161                      (let* ((type  (logand val #x7))
 162                             (fld   (logand (ash val -3) #x1FFFFFFF))
 163                             (field (find fld (proto-fields message) :key #'proto-index))
 164                             (cl    (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 165                             (msg   (and cl (or (find-message-for-class protobuf cl)
 166                                                (find-enum-for-type protobuf cl))))
 167                             ;; It's OK for this to be null
 168                             ;; That means we're parsing some version of a message
 169                             ;; that has the field, but our current message does not
 170                             ;; We still have to deserialize everything, though
 171                             (slot  (proto-value field)))
 172                        ;;--- Check for mismatched types, running past end of buffer, etc
 173                        (declare (ignore type))
 174                        (cond ((eq (proto-required field) :repeated)
 175                               (cond ((and (proto-packed field) (packed-type-p cl))
 176                                      (multiple-value-bind (values idx)
 177                                          (deserialize-packed cl field buffer index)
 178                                        (setq index idx)
 179                                        (when slot
 180                                          (setf (slot-value object slot) values))))
 181                                     ((keywordp cl)
 182                                      (multiple-value-bind (val idx)
 183                                          (deserialize-prim cl field buffer index)
 184                                        (setq index idx)
 185                                        (when slot
 186                                          (setf (slot-value object slot)
 187                                                (nconc (slot-value object slot) (list val))))))
 188                                     ((typep msg 'protobuf-enum)
 189                                      (multiple-value-bind (val idx)
 190                                          (deserialize-enum msg field buffer index)
 191                                        (setq index idx)
 192                                        (when slot
 193                                          (setf (slot-value object slot)
 194                                                (nconc (slot-value object slot) (list val))))))
 195                                     ((typep msg 'protobuf-message)
 196                                      (multiple-value-bind (len idx)
 197                                          (decode-uint32 buffer index)
 198                                        (setq index idx)
 199                                        (let ((obj (deserialize cl (cons msg trace) (+ index len))))
 200                                          (when slot
 201                                            (setf (slot-value object slot)
 202                                                  (nconc (slot-value object slot) (list obj)))))))))
 203                              (t
 204                               (cond ((keywordp cl)
 205                                      (multiple-value-bind (val idx)
 206                                          (deserialize-prim cl field buffer index)
 207                                        (setq index idx)
 208                                        (when slot
 209                                          (setf (slot-value object slot) val))))
 210                                     ((typep msg 'protobuf-enum)
 211                                      (multiple-value-bind (val idx)
 212                                          (deserialize-enum msg field buffer index)
 213                                        (setq index idx)
 214                                        (when slot
 215                                          (setf (slot-value object slot) val))))
 216                                     ((typep msg 'protobuf-message)
 217                                      (multiple-value-bind (len idx)
 218                                          (decode-uint32 buffer index)
 219                                        (setq index idx)
 220                                        (let ((obj (deserialize cl (cons msg trace) (+ index len))))
 221                                          (when slot
 222                                            (setf (slot-value object slot) obj))))))))))))))
 223       (deserialize class (list protobuf)))))
 224
 225
 226 ;;; Object sizes
 227
 228 ;; Allow clients to add their own methods
 229 ;; This is how we address the problem of cycles, e.g. -- if you have an object
 230 ;; that may contain cycles, return the size of the "handle" to the object
 231 (defgeneric object-size (object protobuf &key visited)
 232   (:documentation
 233    "Computes the size in bytes of the object 'object' defined in the schema 'protobuf'.
 234     'visited' is a hash table used to cache object sizes.
 235     The return value is the size of the object in bytes."))
 236
 237 ;; 'visited' is used to cache object sizes
 238 ;; The default method uses meta-data from the protobuf "schema"
 239 (defmethod object-size ((object standard-object) protobuf &key visited)
 240   (check-type protobuf (or protobuf protobuf-message))
 241   (let ((size (and visited (gethash object visited))))
 242     (when size
 243       (return-from object-size size)))
 244   (let* ((class   (class-of object))
 245          (message (find-message-for-class protobuf class))
 246          (size    0))
 247     (assert message ()
 248             "There is no Protobuf message for the class ~S" class)
 249     (labels ((safe-slot-value (object slot)
 250                (if (slot-boundp object slot)
 251                  (slot-value object slot)
 252                  nil))
 253              (do-field (object trace field)
 254                ;; We don't do cycle detection here
 255                ;; If the client needs it, he can define his own 'object-size'
 256                ;; method to clean things up first
 257                (let* ((cl  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 258                       (msg (and cl (loop for p in trace
 259                                          thereis (or (find-message-for-class p cl)
 260                                                      (find-enum-for-type p cl)))))
 261                       (slot (proto-value field)))
 262                  (cond ((eq (proto-required field) :repeated)
 263                         (cond ((and slot (proto-packed field) (packed-type-p cl))
 264                                (iincf size (packed-size (safe-slot-value object slot) cl field)))
 265                               ((and slot (keywordp cl))
 266                                (map () #'(lambda (v)
 267                                            (when (or (eq cl :bool) (not (null v)))
 268                                              (iincf size (prim-size v cl field))))
 269                                        (safe-slot-value object slot)))
 270                               ((and slot (typep msg 'protobuf-enum))
 271                                (map () #'(lambda (v)
 272                                            (when (not (null v))
 273                                              (iincf size (enum-size v msg field))))
 274                                        (safe-slot-value object slot)))
 275                               ((typep msg 'protobuf-message)
 276                                (dolist (v (if slot (safe-slot-value object slot) (list object)))
 277                                  (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 278                                        (len (object-size v protobuf :visited visited)))
 279                                    (iincf size (length32 tag))
 280                                    (iincf size (length32 len)))
 281                                  (map () (curry #'do-field v (cons msg trace))
 282                                       (proto-fields msg))))))
 283                        (t
 284                         (cond ((and slot (keywordp cl))
 285                                (let ((v (safe-slot-value object slot)))
 286                                  (when (or (eq cl :bool) (not (null v)))
 287                                    (iincf size (prim-size v cl field)))))
 288                               ((and slot (typep msg 'protobuf-enum))
 289                                (let ((v (safe-slot-value object slot)))
 290                                  (when (not (null v))
 291                                    (iincf size (enum-size (safe-slot-value object slot) msg field)))))
 292                               ((typep msg 'protobuf-message)
 293                                (let ((v (if slot (safe-slot-value object slot) object)))
 294                                  (when (not (null v))
 295                                    (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 296                                          (len (object-size v protobuf :visited visited)))
 297                                      (iincf size (length32 tag))
 298                                      (iincf size (length32 len)))
 299                                    (map () (curry #'do-field v (cons msg trace))
 300                                            (proto-fields msg)))))))))))
 301       (map () (curry #'do-field object (list message protobuf)) (proto-fields message))
 302       (when visited
 303         (setf (gethash object visited) size))   ;cache the size
 304       size)))