;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;

;;; Free Software published under an MIT-like license. See LICENSE   ;;;

;;;                                                                  ;;;

;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;

;;;                                                                  ;;;
;;; Original author: Scott McKay                                     ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "PROTO-IMPL")


;;; Protocol buffers wire format

;;; Utilities

(eval-when (:compile-toplevel :load-toplevel :execute)

;; If you need to debug the (de)serializer, (pushnew :debug-serialization *features*)
;; Otherwise, we try to make (de)serialization as fast as possible,
;; risking life and limb to do so

(defparameter $optimize-serialization

  #+debug-serialization $optimize-default
  #-debug-serialization $optimize-fast-unsafe)

(defconstant $wire-type-varint 0)
(defconstant $wire-type-64bit  1)
(defconstant $wire-type-string 2)

(defconstant $wire-type-start-group 3)          ;supposedly deprecated, but no such luck
(defconstant $wire-type-end-group   4)          ;supposedly deprecated

(defconstant $wire-type-32bit  5)

)       ;eval-when

(defun make-tag (type index)

  "Given a wire type or the name of a Protobufs type and a field index,
   return the tag that encodes both of them."

  (locally (declare #.$optimize-serialization)

    (if (typep type 'fixnum)

      (ilogior type (iash index 3))

      (let ((type (ecase type
                    ((:int32 :uint32) $wire-type-varint)
                    ((:int64 :uint64) $wire-type-varint)
                    ((:sint32 :sint64) $wire-type-varint)
                    ((:fixed32 :sfixed32) $wire-type-32bit)
                    ((:fixed64 :sfixed64) $wire-type-64bit)
                    ((:string :bytes) $wire-type-string)
                    ((:bool) $wire-type-varint)
                    ((:float) $wire-type-32bit)
                    ((:double) $wire-type-64bit)
                    ;; A few of our homegrown types
                    ((:symbol) $wire-type-string)
                    ((:date :time :datetime :timestamp) $wire-type-64bit))))
        (ilogior type (iash index 3))))))

(define-compiler-macro make-tag (&whole form type index)

  (setq type (fold-symbol type))

  (cond ((typep type 'fixnum)
         `(ilogior ,type (iash ,index 3)))
        ((keywordp type)
         (let ((type (ecase type
                       ((:int32 :uint32) $wire-type-varint)
                       ((:int64 :uint64) $wire-type-varint)
                       ((:sint32 :sint64) $wire-type-varint)
                       ((:fixed32 :sfixed32) $wire-type-32bit)
                       ((:fixed64 :sfixed64) $wire-type-64bit)
                       ((:string :bytes) $wire-type-string)
                       ((:bool) $wire-type-varint)
                       ((:float) $wire-type-32bit)
                       ((:double) $wire-type-64bit)
                       ;; A few of our homegrown types
                       ((:symbol) $wire-type-string)
                       ((:date :time :datetime :timestamp) $wire-type-64bit))))
           `(ilogior ,type (iash ,index 3))))
        (t form)))

(defun fold-symbol (x)

  "Given an expression 'x', constant-fold it until it can be folded no more."

  (let ((last '#:last))
    (loop
      (cond ((eq x last) (return x))
            ((and (listp x)
                  (eq (first x) 'quote)
                  (constantp (second x)))
             (shiftf last x (second x)))
            ((and (symbolp x)
                  (boundp x))
             (shiftf last x (symbol-value x)))
            (t (return x))))))

(defmacro gen-zig-zag (bits)
  "Generate 32- or 64-bit versions of zig-zag encoder/decoder."
  (assert (and (plusp bits) (zerop (mod bits 8))))
  (let* ((zig-zag-encode (fintern "~A~A" 'zig-zag-encode bits))
         (zig-zag-decode (fintern "~A~A" 'zig-zag-decode bits))
         (zig-zag-shift (1+ (- bits))))
    `(progn
       (defun ,zig-zag-encode (val)
         (declare #.$optimize-serialization)
         (declare (type (signed-byte ,bits) val))
         (logxor (ash val 1) (ash val ,zig-zag-shift)))
       (define-compiler-macro ,zig-zag-encode (&whole form val)
         (if (atom val)
           `(locally (declare #.$optimize-serialization
                              (type (signed-byte ,',bits) ,val))
              (logxor (ash ,val 1) (ash ,val ,',zig-zag-shift)))
           form))
       (defun ,zig-zag-decode (val)
         (declare #.$optimize-serialization)
         (declare (type (unsigned-byte ,bits) val))
         (logxor (ash val -1) (- (logand val 1))))
       (define-compiler-macro ,zig-zag-decode (&whole form val)
         (if (atom val)
           `(locally (declare #.$optimize-serialization
                              (type (unsigned-byte ,',bits) ,val))
              (logxor (ash ,val -1) (- (logand ,val 1))))
           form)))))

(gen-zig-zag 32)
(gen-zig-zag 64)

;;; Serializers

;; Serialize 'val' of primitive type 'type' into the buffer

(defun serialize-prim (val type tag buffer index)

  "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.

   The value is given by 'val', the primitive type by 'type'.

   Modifies the buffer in place, and returns the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."

  (declare (type (unsigned-byte 32) tag)

           (type fixnum index))

  (locally (declare #.$optimize-serialization)

    (let ((idx (encode-uint32 tag buffer index)))
      (declare (type fixnum idx))
      (ecase type

        ((:int32 :int64)
         (encode-int val buffer idx))
        ((:uint32)
         (encode-uint32 val buffer idx))
        ((:uint64)
         (encode-uint64 val buffer idx))

        ((:sint32)
         (encode-uint32 (zig-zag-encode32 val) buffer idx))
        ((:sint64)
         (encode-uint64 (zig-zag-encode64 val) buffer idx))
        ((:fixed32)
         (encode-fixed32 val buffer idx))
        ((:sfixed32)
         (encode-sfixed32 val buffer idx))
        ((:fixed64)
         (encode-fixed64 val buffer idx))
        ((:sfixed64)
         (encode-sfixed64 val buffer idx))
        ((:string)

         (encode-string val buffer idx))

        ((:bytes)
         (encode-octets val buffer idx))
        ((:bool)
         (encode-uint32 (if val 1 0) buffer idx))
        ((:float)
         (encode-single val buffer idx))
        ((:double)
         (encode-double val buffer idx))
        ;; A few of our homegrown types
        ((:symbol)

         (let ((val (if (keywordp val)
                      (string val)
                      ;; Non-keyword symbols are consy, avoid them if possible
                      (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))

           (encode-string val buffer idx)))

        ((:date :time :datetime :timestamp)

         (encode-uint64 val buffer idx))))))

(define-compiler-macro serialize-prim (&whole form val type tag buffer index)

  (setq type (fold-symbol type)
        tag  (fold-symbol tag))

  (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
                     :fixed32 :sfixed32 :fixed64 :sfixed64
                     :string :bytes :bool :float :double))

    `(locally (declare #.$optimize-serialization

                       (type (simple-array (unsigned-byte 8)) ,buffer)
                       ;; 'tag' is a constant, no need to declare its type
                       (type fixnum ,index))

       (let ((idx (encode-uint32 ,tag ,buffer ,index)))
         (declare (type fixnum idx))

         ,(ecase type

            ((:int32 :int64)
             `(encode-int ,val ,buffer idx))

            ((:uint32)

             `(encode-uint32 ,val ,buffer idx))

            ((:uint64)

             `(encode-uint64 ,val ,buffer idx))
            ((:sint32)
             `(encode-uint32 (zig-zag-encode32 ,val) ,buffer idx))
            ((:sint64)
             `(encode-uint64 (zig-zag-encode64 ,val) ,buffer idx))
            ((:fixed32)
             `(encode-fixed32 ,val ,buffer idx))
            ((:sfixed32)
             `(encode-sfixed32 ,val ,buffer idx))
            ((:fixed64)
             `(encode-fixed64 ,val ,buffer idx))
            ((:sfixed64)
             `(encode-sfixed64 ,val ,buffer idx))
            ((:string)

             `(encode-string ,val ,buffer idx))

            ((:bytes)
             `(encode-octets ,val ,buffer idx))
            ((:bool)
             `(encode-uint32 (if ,val 1 0) ,buffer idx))
            ((:float)
             `(encode-single ,val ,buffer idx))
            ((:double)
             `(encode-double ,val ,buffer idx)))))
    form))

(defun serialize-packed (values type tag buffer index &optional vectorp)

  "Serializes a set of packed values into the buffer at the given index.
   The values are given by 'values', the primitive type by 'type'.

   Modifies the buffer in place, and returns the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."

  (declare (ignore vectorp)
           (type (simple-array (unsigned-byte 8)) buffer)

           (type (unsigned-byte 32) tag)

           (type fixnum index))

  (locally (declare #.$optimize-serialization)

    (let ((idx (encode-uint32 tag buffer index)))
      (declare (type fixnum idx))

      (multiple-value-bind (full-len len)

          (packed-size values type tag)

        (declare (type fixnum len) (ignore full-len))
        (setq idx (encode-uint32 len buffer idx)))
      (ecase type

        ((:int32 :int64)
         (map () #'(lambda (val) (setq idx (encode-int val buffer idx))) values))
        ((:uint32)
         (map () #'(lambda (val) (setq idx (encode-uint32 val buffer idx))) values))
        ((:uint64)
         (map () #'(lambda (val) (setq idx (encode-uint64 val buffer idx))) values))

        ((:sint32)

         (map () #'(lambda (val) (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))) values))

        ((:sint64)

         (map () #'(lambda (val) (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))) values))

        ((:fixed32)

         (map () #'(lambda (val) (setq idx (encode-fixed32 val buffer idx))) values))

        ((:sfixed32)

         (map () #'(lambda (val) (setq idx (encode-sfixed32 val buffer idx))) values))

        ((:fixed64)

         (map () #'(lambda (val) (setq idx (encode-fixed64 val buffer idx))) values))

        ((:sfixed64)

         (map () #'(lambda (val) (setq idx (encode-sfixed64 val buffer idx))) values))

        ((:bool)

         (map () #'(lambda (val) (setq idx (encode-uint32 (if val 1 0) buffer idx))) values))

        ((:float)

         (map () #'(lambda (val) (setq idx (encode-single val buffer idx))) values))

        ((:double)

         (map () #'(lambda (val) (setq idx (encode-double val buffer idx))) values)))
      idx)))

;; The optimized serializers supply 'vectorp' so we can generate better code
(define-compiler-macro serialize-packed (&whole form values type tag buffer index
                                         &optional (vectorp nil vectorp-p))

  (setq type (fold-symbol type)
        tag  (fold-symbol tag))

  (if (and vectorp-p
           `(member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
                           :fixed32 :sfixed32 :fixed64 :sfixed64
                           :bool :float :double)))

    `(locally (declare #.$optimize-serialization

                       (type (simple-array (unsigned-byte 8)) ,buffer)

                       ;; 'tag' is a constant, no need to declare its type

                       (type fixnum ,index))

       (let ((idx (encode-uint32 ,tag ,buffer ,index)))
         (declare (type fixnum idx))
         (multiple-value-bind (full-len len)
             (packed-size ,values ,type ,tag)
           (declare (type fixnum len) (ignore full-len))
           (setq idx (encode-uint32 len ,buffer idx)))

         (,(if vectorp 'dovector 'dolist) (val ,values)
            ,(ecase type

               ((:int32 :int64)
                `(setq idx (encode-int val ,buffer idx)))

               ((:uint32)
                `(setq idx (encode-uint32 val ,buffer idx)))
               ((:uint64)
                `(setq idx (encode-uint64 val ,buffer idx)))
               ((:sint32)
                `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
               ((:sint64)
                `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
               ((:fixed32)
                `(setq idx (encode-fixed32 val ,buffer idx)))
               ((:sfixed32)
                `(setq idx (encode-sfixed32 val ,buffer idx)))
               ((:fixed64)
                `(setq idx (encode-fixed64 val ,buffer idx)))
               ((:sfixed64)
                `(setq idx (encode-sfixed64 val ,buffer idx)))
               ((:bool)
                `(setq idx (encode-uint32 (if val 1 0) ,buffer idx)))
               ((:float)
                `(setq idx (encode-single val ,buffer idx)))
               ((:double)
                `(setq idx (encode-double val ,buffer idx)))))

         idx))

    form))

(defun serialize-enum (val enum-values tag buffer index)

  "Serializes a Protobufs enum value into the buffer at the given index.

   The value is given by 'val', the enum values are in 'enum-values'.

   Modifies the buffer in place, and returns the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."

  (declare (type list enum-values)
           (type (simple-array (unsigned-byte 8)) buffer)

           (type (unsigned-byte 32) tag)

           (type fixnum index))

  (locally (declare #.$optimize-serialization)

    (let* ((val (let ((e (find val enum-values :key #'proto-value)))

                  (and e (proto-index e))))
           (idx (encode-uint32 tag buffer index)))

      (declare (type (unsigned-byte 32) val)

               (type fixnum idx))

      (encode-uint32 val buffer idx))))

(defun serialize-packed-enum (values enum-values tag buffer index)
  "Serializes Protobufs enum values into the buffer at the given index.
   The values are given by 'values', the enum values are in 'enum-values'.
   Modifies the buffer in place, and returns the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."

  (declare (type list enum-values)
           (type (simple-array (unsigned-byte 8)) buffer)

           (type (unsigned-byte 32) tag)
           (type fixnum index))

  (locally (declare #.$optimize-serialization)

    (let ((idx (encode-uint32 tag buffer index)))
      (declare (type fixnum idx))
      (multiple-value-bind (full-len len)
          (packed-enum-size values enum-values tag)
        (declare (type fixnum len) (ignore full-len))
        (setq idx (encode-uint32 len buffer idx)))

      (map () #'(lambda (val)
                  (let ((val (let ((e (find val enum-values :key #'proto-value)))
                               (and e (proto-index e)))))
                    (declare (type (unsigned-byte 32) val))

                    (setq idx (encode-uint32 val buffer idx)))) values)

      idx)))

;;; Deserializers

;; Deserialize the next object of type 'type'
(defun deserialize-prim (type buffer index)
  "Deserializes the next object of primitive type 'type'.

   Deserializes from the byte vector 'buffer' starting at 'index'.

   Returns the value and and the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."

  (declare (type (simple-array (unsigned-byte 8)) buffer)
           (type fixnum index))

  (locally (declare #.$optimize-serialization)

    (ecase type

      ((:int32 :int64)
       (decode-int buffer index))

      ((:uint32)

       (decode-uint32 buffer index))

      ((:uint64)

       (decode-uint64 buffer index))
      ((:sint32)
       (multiple-value-bind (val idx)
           (decode-uint32 buffer index)
         (values (zig-zag-decode32 val) idx)))
      ((:sint64)
       (multiple-value-bind (val idx)
           (decode-uint64 buffer index)
         (values (zig-zag-decode64 val) idx)))

      ((:fixed32)

       (decode-fixed32 buffer index))

      ((:sfixed32)
       (decode-sfixed32 buffer index))
      ((:fixed64)

       (decode-fixed64 buffer index))

      ((:sfixed64)
       (decode-sfixed64 buffer index))

      ((:string)

       (decode-string buffer index))

      ((:bytes)
       (decode-octets buffer index))
      ((:bool)
       (multiple-value-bind (val idx)
           (decode-uint32 buffer index)

         (values (if (i= val 0) nil t) idx)))

      ((:float)
       (decode-single buffer index))
      ((:double)
       (decode-double buffer index))
      ;; A few of our homegrown types
      ((:symbol)

       ;; Note that this is consy, avoid it if possible

       (multiple-value-bind (val idx)

           (decode-string buffer index)
         (values (make-lisp-symbol val) idx)))

      ((:date :time :datetime :timestamp)
       (decode-uint64 buffer index)))))

(define-compiler-macro deserialize-prim (&whole form type buffer index)

  (setq type (fold-symbol type))

  (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
                     :fixed32 :sfixed32 :fixed64 :sfixed64
                     :string :bytes :bool :float :double))

    `(locally (declare #.$optimize-serialization

                       (type (simple-array (unsigned-byte 8)) ,buffer)
                       (type fixnum ,index))

       ,(ecase type

          ((:int32 :int64)
           `(decode-int ,buffer ,index))

          ((:uint32)

           `(decode-uint32 ,buffer ,index))

          ((:uint64)

           `(decode-uint64 ,buffer ,index))
          ((:sint32)
           `(multiple-value-bind (val idx)
                (decode-uint32 ,buffer ,index)
              (values (zig-zag-decode32 val) idx)))
          ((:sint64)
           `(multiple-value-bind (val idx)
               (decode-uint64 ,buffer ,index)
             (values (zig-zag-decode64 val) idx)))
          ((:fixed32)
           `(decode-fixed32 ,buffer ,index))
          ((:sfixed32)
           `(decode-sfixed32 ,buffer ,index))
          ((:fixed64)
           `(decode-fixed64 ,buffer ,index))
          ((:sfixed64)
           `(decode-sfixed64 ,buffer ,index))
          ((:string)

           `(decode-string ,buffer ,index))

          ((:bytes)
           `(decode-octets ,buffer ,index))
          ((:bool)
           `(multiple-value-bind (val idx)
                (decode-uint32 ,buffer ,index)

              (values (if (i= val 0) nil t) idx)))

          ((:float)
           `(decode-single ,buffer ,index))
          ((:double)
           `(decode-double ,buffer ,index))))
    form))

(defun deserialize-packed (type buffer index)
  "Deserializes the next packed values of type 'type'.

   Deserializes from the byte vector 'buffer' starting at 'index'.

   Returns the value and and the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."

  (declare (type (simple-array (unsigned-byte 8)) buffer)
           (type fixnum index))

  (locally (declare #.$optimize-serialization)

    (multiple-value-bind (len idx)
        (decode-uint32 buffer index)

      (declare (type (unsigned-byte 32) len)
               (type fixnum idx))

      (let ((end (i+ idx len)))

        (declare (type (unsigned-byte 32) end))

        (with-collectors ((values collect-value))
          (loop
            (when (>= idx end)
              (return-from deserialize-packed (values values idx)))
            (multiple-value-bind (val nidx)
                (ecase type

                  ((:int32 :int64)
                   (decode-int buffer idx))

                  ((:uint32)

                   (decode-uint32 buffer idx))

                  ((:uint64)

                   (decode-uint64 buffer idx))
                  ((:sint32)

                   (multiple-value-bind (val nidx)

                       (decode-uint32 buffer idx)

                     (values (zig-zag-decode32 val) nidx)))

                  ((:sint64)

                   (multiple-value-bind (val nidx)

                       (decode-uint64 buffer idx)

                     (values (zig-zag-decode64 val) nidx)))

                  ((:fixed32)

                   (decode-fixed32 buffer idx))

                  ((:sfixed32)
                   (decode-sfixed32 buffer idx))
                  ((:fixed64)

                   (decode-fixed64 buffer idx))

                  ((:sfixed64)
                   (decode-sfixed64 buffer idx))

                  ((:bool)
                   (multiple-value-bind (val nidx)
                       (decode-uint32 buffer idx)
                     (values (if (i= val 0) nil t) nidx)))

                  ((:float)
                   (decode-single buffer idx))
                  ((:double)
                   (decode-double buffer idx)))
              (collect-value val)
              (setq idx nidx))))))))

(define-compiler-macro deserialize-packed (&whole form type buffer index)

  (setq type (fold-symbol type))

  (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
                     :fixed32 :sfixed32 :fixed64 :sfixed64

                     :bool :float :double))

    `(locally (declare #.$optimize-serialization

                       (type (simple-array (unsigned-byte 8)) ,buffer)
                       (type fixnum ,index))

       (block deserialize-packed
         (multiple-value-bind (len idx)
             (decode-uint32 ,buffer ,index)
           (declare (type (unsigned-byte 32) len)
                    (type fixnum idx))
           (let ((end (i+ idx len)))
             (declare (type (unsigned-byte 32) end))
             (with-collectors ((values collect-value))
               (loop
                 (when (>= idx end)
                   (return-from deserialize-packed (values values idx)))
                 (multiple-value-bind (val nidx)
                     ,(ecase type

                        ((:int32 :int64)
                         `(decode-int ,buffer idx))

                        ((:uint32)

                         `(decode-uint32 ,buffer idx))

                        ((:uint64)

                         `(decode-uint64 ,buffer idx))
                        ((:sint32)

                         `(multiple-value-bind (val nidx)

                              (decode-uint32 ,buffer idx)

                            (values (zig-zag-decode32 val) nidx)))

                        ((:sint64)

                         `(multiple-value-bind (val nidx)

                              (decode-uint64 ,buffer idx)

                            (values (zig-zag-decode64 val) nidx)))

                        ((:fixed32)
                         `(decode-fixed32 ,buffer idx))
                        ((:sfixed32)
                         `(decode-sfixed32 ,buffer idx))
                        ((:fixed64)
                         `(decode-fixed64 ,buffer idx))
                        ((:sfixed64)
                         `(decode-sfixed64 ,buffer idx))

                        ((:bool)
                         `(multiple-value-bind (val nidx)
                              (decode-uint32 ,buffer idx)
                            (values (if (i= val 0) nil t) nidx)))

                        ((:float)
                         `(decode-single ,buffer idx))
                        ((:double)
                         `(decode-double ,buffer idx)))
                   (collect-value val)
                   (setq idx nidx))))))))

    form))

(defun deserialize-enum (enum-values buffer index)
  "Deserializes the next enum value take from 'enum-values'.

   Deserializes from the byte vector 'buffer' starting at 'index'.

   Returns the value and and the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."

  (declare (type list enum-values)
           (type (simple-array (unsigned-byte 8)) buffer)

           (type fixnum index))

  (locally (declare #.$optimize-serialization)

    (multiple-value-bind (val idx)

        (decode-int buffer index)

      (let ((val (let ((e (find val enum-values :key #'proto-index)))

                   (and e (proto-value e)))))
        (values val idx)))))

(defun deserialize-packed-enum (enum-values buffer index)
  "Deserializes the next packed enum values given in 'enum-values'.
   Deserializes from the byte vector 'buffer' starting at 'index'.
   Returns the value and and the new index into the buffer.
   Watch out, this function turns off most type checking and all array bounds checking."