wire-format.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 ;;; Protocol buffers wire format
  15
  16 ;; Serialize 'object' of primitive type 'type', described by the protobuf field 'field'
  17 ;; Serializes into the byte vector 'buffer' starting at 'index'
  18 ;; Returns the new index into the buffer
  19 (defun serialize-prim (val type field buffer index)
  20   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  21     (ecase type
  22       ((:int32 :uint32)
  23        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  24               (idx (encode-uint32 tag buffer index)))
  25          (declare (type fixnum tag idx))
  26          (encode-uint32 val buffer idx)))
  27       ((:int64 :uint64)
  28        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  29               (idx (encode-uint32 tag buffer index)))
  30          (declare (type fixnum tag idx))
  31          (encode-uint64 val buffer idx)))
  32       ((:sint32)
  33        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  34               (idx (encode-uint32 tag buffer index)))
  35          (declare (type fixnum tag idx))
  36          (encode-uint32 (zig-zag-encode32 val) buffer idx)))
  37       ((:sint64)
  38        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  39               (idx (encode-uint32 tag buffer index)))
  40          (declare (type fixnum tag idx))
  41          (encode-uint64 (zig-zag-encode64 val) buffer idx)))
  42       ((:fixed32 :sfixed32)
  43        (let* ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3)))
  44               (idx (encode-uint32 tag buffer index)))
  45          (declare (type fixnum tag idx))
  46          (encode-uint32 val buffer idx)))
  47       ((:fixed64 :sfixed64)
  48        (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
  49               (idx (encode-uint32 tag buffer index)))
  50          (declare (type fixnum tag idx))
  51          (encode-uint64 val buffer idx)))
  52       ((:string)
  53        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
  54               (idx (encode-uint32 tag buffer index)))
  55                (declare (type fixnum tag idx))
  56          (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
  57       ((:bytes)
  58        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
  59               (idx (encode-uint32 tag buffer index)))
  60          (declare (type fixnum tag idx))
  61          (encode-octets val buffer idx)))
  62       ((:bool)
  63        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  64               (idx (encode-uint32 tag buffer index)))
  65          (declare (type fixnum tag idx))
  66          (encode-uint32 (if val 1 0) buffer idx)))
  67       ((:float)
  68        (let* ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3)))
  69               (idx (encode-uint32 tag buffer index)))
  70          (declare (type fixnum tag idx))
  71          (encode-single val buffer idx)))
  72       ((:double)
  73        (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
  74               (idx (encode-uint32 tag buffer index)))
  75          (declare (type fixnum tag idx))
  76          (encode-double val buffer idx)))
  77       ;; A few of our homegrown types
  78       ((:symbol)
  79        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
  80               (idx (encode-uint32 tag buffer index))
  81               (val (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val))))
  82          ;; Call 'string' in case we are trying to serialize a symbol name
  83          (declare (type fixnum tag idx))
  84          (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
  85       ((:date :time :datetime :timestamp)
  86        (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
  87               (idx (encode-uint32 tag buffer index)))
  88          (declare (type fixnum tag idx))
  89          (encode-uint64 val buffer idx))))))
  90
  91 (defun serialize-packed (values type field buffer index)
  92   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  93     (let* ((wtype (ecase type
  94                     ((:int32 :int64)   $wire-type-varint)
  95                     ((:uint32 :uint64) $wire-type-varint)
  96                     ((:sint32 :sint64) $wire-type-varint)
  97                     ((:fixed32 :sfixed32) $wire-type-32bit)
  98                     ((:fixed64 :sfixed64) $wire-type-64bit)
  99                     ((:float)  $wire-type-32bit)
 100                     ((:double) $wire-type-64bit)))
 101            (tag (ilogior wtype (iash (proto-index field) 3)))
 102            (idx (encode-uint32 tag buffer index)))
 103       (declare (type fixnum wtype tag idx))
 104       (multiple-value-bind (full-len len)
 105           (packed-size values type field)
 106         (declare (type fixnum len) (ignore full-len))
 107         (setq idx (encode-uint32 len buffer idx)))
 108       (ecase type
 109         ((:int32 :uint32)
 110          (dolist (val values idx)
 111            (setq idx (encode-uint32 val buffer idx))))
 112         ((:int64 :uint64)
 113          (dolist (val values idx)
 114            (setq idx (encode-uint64 val buffer idx))))
 115         ((:sint32)
 116          (dolist (val values idx)
 117            (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))))
 118         ((:sint64)
 119          (dolist (val values idx)
 120            (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))))
 121         ((:fixed32 :sfixed32)
 122          (dolist (val values idx)
 123            (setq idx (encode-uint32 val buffer idx))))
 124         ((:fixed64 :sfixed64)
 125          (dolist (val values idx)
 126            (setq idx (encode-uint64 val buffer idx))))
 127         ((:float)
 128          (dolist (val values idx)
 129            (setq idx (encode-single val buffer idx))))
 130         ((:double)
 131          (dolist (val values idx)
 132            (setq idx (encode-double val buffer idx))))))))
 133
 134 ;; Serialize 'object' of enum type 'type', described by the protobuf field 'field'
 135 ;; Serializes into the byte vector 'buffer' starting at 'index'
 136 ;; Returns the new index into the buffer
 137 (defun serialize-enum (val enum field buffer index)
 138   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 139     (let* ((val (let ((e (find val (proto-values enum) :key #'proto-value)))
 140                   (and e (proto-index e))))
 141            (tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
 142            (idx (encode-uint32 tag buffer index)))
 143       (declare (type fixnum val tag idx))
 144       (encode-uint32 val buffer idx))))
 145
 146
 147 ;; Deserialize the next object 'type', described by the protobuf field 'field'
 148 ;; Deserializes from the byte vector 'buffer' starting at 'index'
 149 ;; Returns the value and and the new index into the buffer
 150 (defun deserialize-prim (type field buffer index)
 151   (declare (ignore field))
 152   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 153     (ecase type
 154       ((:int32 :uint32)
 155        (decode-uint32 buffer index))
 156       ((:int64 :uint64)
 157        (decode-uint64 buffer index))
 158       ((:sint32)
 159        (multiple-value-bind (val idx)
 160            (decode-uint32 buffer index)
 161          (values (zig-zag-decode32 val) idx)))
 162       ((:sint64)
 163        (multiple-value-bind (val idx)
 164            (decode-uint64 buffer index)
 165          (values (zig-zag-decode64 val) idx)))
 166       ((:fixed32 :sfixed32)
 167        (decode-uint32 buffer index))
 168       ((:fixed64 :sfixed64)
 169        (decode-uint64 buffer index))
 170       ((:string)
 171        (multiple-value-bind (val idx)
 172            (decode-octets buffer index)
 173          (values (babel:octets-to-string val :encoding :utf-8) idx)))
 174       ((:bytes)
 175        (decode-octets buffer index))
 176       ((:bool)
 177        (multiple-value-bind (val idx)
 178            (decode-uint32 buffer index)
 179          (values (if (zerop val) nil t) idx)))
 180       ((:float)
 181        (decode-single buffer index))
 182       ((:double)
 183        (decode-double buffer index))
 184       ;; A few of our homegrown types
 185       ((:symbol)
 186        (multiple-value-bind (val idx)
 187            (decode-octets buffer index)
 188          (let* ((val   (babel:octets-to-string val :encoding :utf-8))
 189                 (colon (position #\: val))
 190                 (pkg   (subseq val 0 colon))
 191                 (sym   (subseq val (i+ colon 1))))
 192            (values (intern sym pkg) idx))))
 193       ((:date :time :datetime :timestamp)
 194        (decode-uint64 buffer index)))))
 195
 196 (defun deserialize-packed (type field buffer index)
 197   (declare (ignore field))
 198   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 199     (multiple-value-bind (len idx)
 200         (decode-uint32 buffer index)
 201       (declare (type fixnum len idx))
 202       (let ((end (i+ idx len)))
 203         (declare (type fixnum end))
 204         (with-collectors ((values collect-value))
 205           (loop
 206             (when (>= idx end)
 207               (return-from deserialize-packed (values values idx)))
 208             (multiple-value-bind (val nidx)
 209                 (ecase type
 210                   ((:int32 :uint32)
 211                    (decode-uint32 buffer idx))
 212                   ((:int64 :uint64)
 213                    (decode-uint64 buffer idx))
 214                   ((:sint32)
 215                    (multiple-value-bind (val idx)
 216                        (decode-uint32 buffer idx)
 217                      (values (zig-zag-decode32 val) idx)))
 218                   ((:sint64)
 219                    (multiple-value-bind (val idx)
 220                        (decode-uint64 buffer idx)
 221                      (values (zig-zag-decode64 val) idx)))
 222                   ((:fixed32 :sfixed32)
 223                    (decode-uint32 buffer idx))
 224                   ((:fixed64 :sfixed64)
 225                    (decode-uint64 buffer idx))
 226                   ((:float)
 227                    (decode-single buffer idx))
 228                   ((:double)
 229                    (decode-double buffer idx)))
 230               (collect-value val)
 231               (setq idx nidx))))))))
 232
 233 (defun deserialize-enum (enum field buffer index)
 234   (declare (ignore field))
 235   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 236     (multiple-value-bind (val idx)
 237         (decode-uint32 buffer index)
 238       (let ((val (let ((e (find val (proto-values enum) :key #'proto-index)))
 239                    (and e (proto-value e)))))
 240         (values val idx)))))
 241
 242
 243 ;; Returns the size in bytes that the primitive object will take when serialized
 244 (defun prim-size (val type field)
 245   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 246     (ecase type
 247       ((:int32 :uint32)
 248        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 249          (i+ (length32 tag) (length32 val))))
 250       ((:int64 :uint64)
 251        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 252          (i+ (length32 tag) (length64 val))))
 253       ((:sint32)
 254        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 255          (i+ (length32 tag) (length32 (zig-zag-encode32 val)))))
 256       ((:sint64)
 257        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 258          (i+ (length32 tag) (length64 (zig-zag-encode64 val)))))
 259       ((:fixed32 :sfixed32)
 260        (let ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3))))
 261          (i+ (length32 tag) 4)))
 262       ((:fixed64 :sfixed64)
 263        (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
 264          (i+ (length32 tag) 8)))
 265       ((:string)
 266        (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 267              (len (babel:string-size-in-octets val :encoding :utf-8)))
 268          (i+ (length32 tag) (length32 len) len)))
 269       ((:bytes)
 270        (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 271          (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 272                (len (length val)))
 273            (i+ (length32 tag) (length32 len) len))))
 274       ((:bool)
 275        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 276          (i+ (length32 tag) 1)))
 277       ((:float)
 278        (let ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3))))
 279          (i+ (length32 tag) 4)))
 280       ((:double)
 281        (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
 282          (i+ (length32 tag) 8)))
 283       ;; A few of our homegrown types
 284       ((:symbol)
 285        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 286               (len (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val)))))
 287          (i+ (length32 tag) (length32 len) len)))
 288       ((:date :time :datetime :timestamp)
 289        (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
 290          (i+ (length32 tag) 8))))))
 291
 292 (defun packed-size (values type field)
 293   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 294     (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
 295           (len (loop for val in values
 296                      summing (ecase type
 297                                ((:int32 :uint32) (length32 val))
 298                                ((:int64 :uint64) (length64 val))
 299                                ((:sint32) (length32 (zig-zag-encode32 val)))
 300                                ((:sint64) (length64 (zig-zag-encode64 val)))
 301                                ((:fixed32 :sfixed32) 4)
 302                                ((:fixed64 :sfixed64) 8)
 303                                ((:float) 4)
 304                                ((:double) 8)))))
 305       (declare (type fixnum tag len))
 306       ;; Two value: the full size of the packed object, and the size
 307       ;; of just the payload
 308       (values (i+ (length32 tag) (length32 len) len) len))))
 309
 310 ;; Returns the size in bytes that the enum object will take when serialized
 311 (defun enum-size (val enum field)
 312   (let ((val (let ((e (find val (proto-values enum) :key #'proto-value)))
 313                (and e (proto-index e))))
 314         (tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 315     (i+ (length32 tag) (length32 val))))
 316
 317
 318 ;;; Raw encoders
 319
 320 ;; Encode the value into the buffer at the given index,
 321 ;; then return the new index into the buffer
 322 (defun encode-uint32 (val buffer index)
 323   (declare (type fixnum index)
 324            (type (simple-array (unsigned-byte 8)) buffer))
 325   (assert (< val #.(ash 1 32)) ()
 326           "The value ~D is longer than 32 bits" val)
 327   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 328     ;; Seven bits at a time, least significant bits first
 329     (loop do (let ((bits (ldb #.(byte 7 0) val)))
 330                (declare (type fixnum bits))
 331                (setq val (ash val -7))
 332                (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 333                (iincf index))
 334           until (zerop val)))
 335   (values index buffer))                        ;return the buffer to improve 'trace'
 336
 337 (defun encode-uint64 (val buffer index)
 338   (declare (type fixnum index)
 339            (type (simple-array (unsigned-byte 8)) buffer))
 340   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 341     (loop do (let ((bits (ldb #.(byte 7 0) val)))
 342                (declare (type fixnum bits))
 343                (setq val (ash val -7))
 344                (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 345                (iincf index))
 346           until (zerop val)))
 347   (values index buffer))
 348
 349 (defun encode-single (val buffer index)
 350   (declare (type fixnum index)
 351            (type (simple-array (unsigned-byte 8)) buffer))
 352   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 353     ;;---*** DO ENCODING OF SINGLE FLOATS
 354     val buffer index))
 355
 356 (defun encode-double (val buffer index)
 357   (declare (type fixnum index)
 358            (type (simple-array (unsigned-byte 8)) buffer))
 359   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 360     ;;---*** DO ENCODING OF DOUBLE FLOATS
 361     val buffer index))
 362
 363 (defun encode-octets (octets buffer index)
 364   (declare (type fixnum index)
 365            (type (simple-array (unsigned-byte 8)) buffer))
 366   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 367     (let* ((len (length octets))
 368            (idx (encode-uint32 len buffer index)))
 369       (declare (type fixnum len idx))
 370       (replace buffer octets :start1 idx)
 371       (values (i+ idx len) buffer))))
 372
 373 (defun zig-zag-encode32 (val)
 374   (assert (< (integer-length val) 32))
 375   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 376     (logxor (ash val 1) (ash val -31))))
 377
 378 (defun zig-zag-encode64 (val)
 379   (assert (< (integer-length val) 64))
 380   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 381     (logxor (ash val 1) (ash val -63))))
 382
 383
 384 ;;; Raw decoders
 385
 386 ;; Decode the value from the buffer at the given index,
 387 ;; then return the value and new index into the buffer
 388 (defun decode-uint32 (buffer index)
 389   (declare (type fixnum index)
 390            (type (simple-array (unsigned-byte 8)) buffer))
 391   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 392     ;; Seven bits at a time, least significant bits first
 393     (loop with val fixnum = 0
 394           for places fixnum upfrom 0 by 7
 395           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 396           do (setq val (ilogior val (ash (ldb #.(byte 7 0) byte) places)))
 397           until (i< byte 128)
 398           finally (progn
 399                     (assert (< val #.(ash 1 32)) ()
 400                             "The value ~D is longer than 32 bits" val)
 401                     (return (values val index))))))
 402
 403 (defun decode-uint64 (buffer index)
 404   (declare (type fixnum index)
 405            (type (simple-array (unsigned-byte 8)) buffer))
 406   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 407     ;; Seven bits at a time, least significant bits first
 408     (loop with val fixnum = 0
 409           for places fixnum upfrom 0 by 7
 410           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 411           do (setq val (ilogior val (ash (ldb #.(byte 7 0) byte) places)))
 412           until (i< byte 128)
 413           finally (return (values val index)))))
 414
 415 (defun decode-single (buffer index)
 416   (declare (type fixnum index)
 417            (type (simple-array (unsigned-byte 8)) buffer))
 418   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 419     ;;---*** DO DECODING OF SINGLE FLOATS
 420     buffer index))
 421
 422 (defun decode-double (buffer index)
 423   (declare (type fixnum index)
 424            (type (simple-array (unsigned-byte 8)) buffer))
 425   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 426     ;;---*** DO DECODING OF DOUBLE FLOATS
 427     buffer index))
 428
 429 (defun decode-octets (buffer index)
 430   (declare (type fixnum index)
 431            (type (simple-array (unsigned-byte 8)) buffer))
 432   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 433     (multiple-value-bind (len idx)
 434         (decode-uint32 buffer index)
 435       (declare (type fixnum len idx))
 436       (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
 437
 438 (defun zig-zag-decode32 (val)
 439   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 440     (logxor (ash val -1) (- (logand val 1)))))
 441
 442 (defun zig-zag-decode64 (val)
 443   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 444     (logxor (ash val -1) (- (logand val 1)))))
 445
 446
 447 ;;; Raw lengths
 448
 449 (defun length32 (val)
 450   (assert (< val #.(ash 1 32)) ()
 451           "The value ~D is longer than 32 bits" val)
 452   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 453     (let ((size 0))
 454       (declare (type fixnum size))
 455       (loop do (progn
 456                  (setq val (ash val -7))
 457                  (iincf size))
 458             until (zerop val))
 459       size)))
 460
 461 (defun length64 (val)
 462   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 463     (let ((size 0))
 464       (declare (type fixnum size))
 465       (loop do (progn
 466                  (setq val (ash val -7))
 467                  (iincf size))
 468             until (zerop val))
 469       size)))