From e3e70a2c2e267a42f890056f22c6f1549b483c93 Mon Sep 17 00:00:00 2001 From: Scott McKay Date: Tue, 6 Mar 2012 20:46:38 +0000 Subject: [PATCH] Reorder a few things for readability. Make it possible to deserialize objects that were serialized from a previous, compatibile version of a message. Add 'protobuf-upgradable' predicate, which returns true iff a new version of a .proto schema is compatible with an older version. git-svn-id: http://svn.internal.itasoftware.com/svn/ita/branches/qres/swm/borgify-1/qres/lisp/quux/protobufs@532501 f8382938-511b-0410-9cdd-bb47b084005c --- clos-transform.lisp | 18 +++--- define-proto.lisp | 3 +- model-classes.lisp | 110 ++++++++++++++++++------------------ proto-pkgdcl.lisp | 5 +- serialize.lisp | 25 ++++++--- upgradable.lisp | 132 ++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 220 insertions(+), 73 deletions(-) create mode 100644 upgradable.lisp diff --git a/clos-transform.lisp b/clos-transform.lisp index ec798f5..6a201d4 100644 --- a/clos-transform.lisp +++ b/clos-transform.lisp @@ -37,9 +37,9 @@ (defun class-to-protobuf-message (class &key slot-filter type-filter enum-filter value-filter) (let* ((class (find-class class)) (slots (class-slots class))) - (with-collectors ((fields collect-field) + (with-collectors ((enums collect-enum) (msgs collect-msg) - (enums collect-enum)) + (fields collect-field)) (loop with index = 1 for s in slots doing (multiple-value-bind (field msg enum) @@ -48,19 +48,19 @@ :type-filter type-filter :enum-filter enum-filter :value-filter value-filter) - (when field - (incf index 1) - (collect-field field)) + (when enum + (collect-enum enum)) (when msg (collect-msg msg)) - (when enum - (collect-enum enum)))) + (when field + (incf index 1) + (collect-field field)))) (make-instance 'protobuf-message :name (proto-class-name (class-name class)) :class (class-name class) - :fields fields + :enums (delete-duplicates enums :key #'proto-name :test #'string-equal) :messages (delete-duplicates msgs :key #'proto-name :test #'string-equal) - :enums (delete-duplicates enums :key #'proto-name :test #'string-equal))))) + :fields fields)))) ;; Returns a field, (optionally) an inner message, and (optionally) an inner enum (defun slot-to-protobuf-field (slot index slots &key slot-filter type-filter enum-filter value-filter) diff --git a/define-proto.lisp b/define-proto.lisp index 8920650..92e18ba 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -45,13 +45,14 @@ (collect-msg model)) ((define-service) (collect-svc model))))) + ;;--- This should warn if the old one isn't upgradable to the new one (let ((sname (fintern "*~A*" name))) `(progn ,@forms (defvar ,sname (make-instance 'protobuf :name ,(or proto-name (proto-class-name name)) :package ,(if (stringp package) package (string-downcase (string package))) - :imports ',(if (consp import) import (list import)) + :imports ',(if (listp import) import (list import)) :syntax ,syntax :options '(,@options) :enums (list ,@enums) diff --git a/model-classes.lisp b/model-classes.lisp index 3800020..7c32bbb 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -35,14 +35,14 @@ :reader proto-options :initarg :options :initform ()) - (messages :type (list-of protobuf-message) ;the set of messages - :accessor proto-messages - :initarg :messages - :initform ()) (enums :type (list-of protobuf-enum) ;the set of enum types :accessor proto-enums :initarg :enums :initform ()) + (messages :type (list-of protobuf-message) ;the set of messages + :accessor proto-messages + :initarg :messages + :initform ()) (services :type (list-of protobuf-service) :accessor proto-services :initarg :services @@ -65,6 +65,49 @@ (some #'(lambda (msg) (find-enum-for-type msg type)) (proto-messages protobuf)))) +;; A protobuf enumeration +(defclass protobuf-enum () + ((name :type string ;the Protobuf name for the enum type + :reader proto-name + :initarg :name) + (class :type (or null symbol) ;the Lisp type it represents + :accessor proto-class + :initarg :class + :initform nil) + (values :type (list-of protobuf-enum-value) ;all the values for this enum type + :accessor proto-values + :initarg :values + :initform ()) + (comment :type (or null string) + :accessor proto-comment + :initarg :comment + :initform nil))) + +(defmethod print-object ((e protobuf-enum) stream) + (print-unprintable-object (e stream :type t :identity t) + (format stream "~A~@[ (~S)~]" + (proto-name e) (proto-class e)))) + + +;; A protobuf value within an enumeration +(defclass protobuf-enum-value () + ((name :type string ;the name of the enum value + :reader proto-name + :initarg :name) + (index :type (integer 1 #.(1- (ash 1 32))) ;the index of the enum value + :accessor proto-index + :initarg :index) + (value :type (or null symbol) + :accessor proto-value ;the Lisp value of the enum + :initarg :value + :initform nil))) + +(defmethod print-object ((v protobuf-enum-value) stream) + (print-unprintable-object (v stream :type t :identity t) + (format stream "~A = ~D~@[ (~S)~]" + (proto-name v) (proto-index v) (proto-value v)))) + + ;; A protobuf message (defclass protobuf-message () ((name :type string ;the Protobuf name for the message @@ -74,18 +117,18 @@ :accessor proto-class :initarg :class :initform nil) - (fields :type (list-of protobuf-field) ;the fields - :accessor proto-fields - :initarg :fields - :initform ()) - (messages :type (list-of protobuf-message) ;the embedded messages - :accessor proto-messages - :initarg :messages - :initform ()) (enums :type (list-of protobuf-enum) ;the embedded enum types :accessor proto-enums :initarg :enums :initform ()) + (messages :type (list-of protobuf-message) ;the embedded messages + :accessor proto-messages + :initarg :messages + :initform ()) + (fields :type (list-of protobuf-field) ;the fields + :accessor proto-fields + :initarg :fields + :initform ()) (comment :type (or null string) :accessor proto-comment :initarg :comment @@ -149,49 +192,6 @@ (proto-index f)))) -;; A protobuf enumeration -(defclass protobuf-enum () - ((name :type string ;the Protobuf name for the enum type - :reader proto-name - :initarg :name) - (class :type (or null symbol) ;the Lisp type it represents - :accessor proto-class - :initarg :class - :initform nil) - (values :type (list-of protobuf-enum-value) ;all the values for this enum type - :accessor proto-values - :initarg :values - :initform ()) - (comment :type (or null string) - :accessor proto-comment - :initarg :comment - :initform nil))) - -(defmethod print-object ((e protobuf-enum) stream) - (print-unprintable-object (e stream :type t :identity t) - (format stream "~A~@[ (~S)~]" - (proto-name e) (proto-class e)))) - - -;; A protobuf value within an enumeration -(defclass protobuf-enum-value () - ((name :type string ;the name of the enum value - :reader proto-name - :initarg :name) - (index :type (integer 1 #.(1- (ash 1 32))) ;the index of the enum value - :accessor proto-index - :initarg :index) - (value :type (or null symbol) - :accessor proto-value ;the Lisp value of the enum - :initarg :value - :initform nil))) - -(defmethod print-object ((v protobuf-enum-value) stream) - (print-unprintable-object (v stream :type t :identity t) - (format stream "~A = ~D~@[ (~S)~]" - (proto-name v) (proto-index v) (proto-value v)))) - - ;; A protobuf service (defclass protobuf-service () ((name :type string ;the Protobuf name for the service diff --git a/proto-pkgdcl.lisp b/proto-pkgdcl.lisp index 5a0de16..2239f1f 100644 --- a/proto-pkgdcl.lisp +++ b/proto-pkgdcl.lisp @@ -34,12 +34,15 @@ "PARSE-PROTOBUF" "PARSE-PROTOBUF-FROM-STREAM" - ;; Protobufs defining macros + ;; Protobuf defining macros "DEFINE-PROTO" "DEFINE-ENUM" "DEFINE-MESSAGE" "DEFINE-SERVICE" + ;; Upgradability testing + "PROTOBUF-UPGRADABLE" + ;; CLOS to Protobufs transformer "WRITE-PROTOBUF-SCHEMA-FOR-CLASSES" diff --git a/serialize.lisp b/serialize.lisp index 93052cb..26305a8 100644 --- a/serialize.lisp +++ b/serialize.lisp @@ -134,6 +134,10 @@ (cl (if (eq (proto-class field) 'boolean) :bool (proto-class field))) (msg (and cl (or (find-message-for-class protobuf cl) (find-enum-for-type protobuf cl)))) + ;; It's OK for this to be null + ;; That means we're parsing some version of a message + ;; that has the field, but our current message does not + ;; We still have to deserialize everything, though (slot (proto-value field))) ;;---*** Check for mismatched types, running past end of buffer, etc (declare (ignore type)) @@ -142,40 +146,47 @@ (multiple-value-bind (values idx) (deserialize-packed cl field buffer index) (setq index idx) - (setf (slot-value object slot) values))) + (when slot + (setf (slot-value object slot) values)))) ((keywordp cl) (multiple-value-bind (val idx) (deserialize-prim cl field buffer index) (setq index idx) - (setf (slot-value object slot) (nconc (slot-value object slot) (list val))))) + (when slot + (setf (slot-value object slot) (nconc (slot-value object slot) (list val)))))) ((typep msg 'protobuf-enum) (multiple-value-bind (val idx) (deserialize-enum msg field buffer index) (setq index idx) - (setf (slot-value object slot) (nconc (slot-value object slot) (list val))))) + (when slot + (setf (slot-value object slot) (nconc (slot-value object slot) (list val)))))) ((typep msg 'protobuf-message) (multiple-value-bind (len idx) (decode-uint32 buffer index) (setq index idx) (let ((obj (deserialize cl (cons msg trace) (+ index len)))) - (setf (slot-value object slot) (nconc (slot-value object slot) (list obj)))))))) + (when slot + (setf (slot-value object slot) (nconc (slot-value object slot) (list obj))))))))) (t (cond ((keywordp cl) (multiple-value-bind (val idx) (deserialize-prim cl field buffer index) (setq index idx) - (setf (slot-value object slot) val))) + (when slot + (setf (slot-value object slot) val)))) ((typep msg 'protobuf-enum) (multiple-value-bind (val idx) (deserialize-enum msg field buffer index) (setq index idx) - (setf (slot-value object slot) val))) + (when slot + (setf (slot-value object slot) val)))) ((typep msg 'protobuf-message) (multiple-value-bind (len idx) (decode-uint32 buffer index) (setq index idx) (let ((obj (deserialize cl (cons msg trace) (+ index len)))) - (setf (slot-value object slot) obj))))))))))))) + (when slot + (setf (slot-value object slot) obj)))))))))))))) (deserialize class (list protobuf))))) diff --git a/upgradable.lisp b/upgradable.lisp new file mode 100644 index 0000000..f1b17ba --- /dev/null +++ b/upgradable.lisp @@ -0,0 +1,132 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; Confidential and proprietary information of ITA Software, Inc. ;;; +;;; ;;; +;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;; +;;; ;;; +;;; Original author: Scott McKay ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package "PROTO-IMPL") + + +;;; Can a version of a protobuf be upgraded to a new version + +(defmethod protobuf-upgradable ((old protobuf) (new protobuf)) + (and + ;; Are they named the same? + (string= (proto-name old) (proto-name new)) + (string= (proto-package old) (proto-package new)) + ;; Is every enum in 'old' upgradable to an enum in 'new'? + (loop for old-enum in (proto-enums old) + as new-enum = (find (proto-name old-enum) (proto-enums new) + :key #'proto-name :test #'string=) + always (and new-enum (protobuf-upgradable old-enum new-enum))) + ;; Is every message in 'old' upgradable to a message in 'new'? + (loop for old-msg in (proto-messages old) + as new-msg = (find (proto-name old-msg) (proto-messages new) + :key #'proto-name :test #'string=) + always (and new-msg (protobuf-upgradable old-msg new-msg))) + ;; Is every service in 'old' upgradable to a service in 'new'? + (loop for old-svc in (proto-services old) + as new-svc = (find (proto-name old-svc) (proto-services new) + :key #'proto-name :test #'string=) + always (and new-svc (protobuf-upgradable old-svc new-svc))))) + + +(defmethod protobuf-upgradable ((old protobuf-enum) (new protobuf-enum)) + (and + ;; Are they named the same? + (string= (proto-name old) (proto-name new)) + ;; Is every value in 'old' upgradable to a value in 'new'? + (loop for old-val in (proto-values old) + as new-val = (find (proto-name old-val) (proto-values new) + :key #'proto-name :test #'string=) + always (and new-val (protobuf-upgradable old-val new-val))))) + +(defmethod protobuf-upgradable ((old protobuf-enum-value) (new protobuf-enum-value)) + (and + ;; Are they named the same? + (string= (proto-name old) (proto-name new)) + ;; Do they have the same index? + (= (proto-index old) (proto-index new)))) + + +(defmethod protobuf-upgradable ((old protobuf-message) (new protobuf-message)) + (and + ;; Are they named the same? + (string= (proto-name old) (proto-name new)) + ;; Is every enum in 'old' upgradable to an enum in 'new'? + (loop for old-enum in (proto-enums old) + as new-enum = (find (proto-name old-enum) (proto-enums new) + :key #'proto-name :test #'string=) + always (and new-enum (protobuf-upgradable old-enum new-enum))) + ;; Is every message in 'old' upgradable to a message in 'new'? + (loop for old-msg in (proto-messages old) + as new-msg = (find (proto-name old-msg) (proto-messages new) + :key #'proto-name :test #'string=) + always (and new-msg (protobuf-upgradable old-msg new-msg))) + ;; Is every required field in 'old' upgradable to a field in 'new'? + ;; (Optional fields are safe to remove) + (loop for old-fld in (proto-fields old) + as new-fld = (find (proto-name old-fld) (proto-fields new) + :key #'proto-name :test #'string=) + always (if new-fld + (protobuf-upgradable old-fld new-fld) + (not (eq (proto-required old) :required)))))) + +(defmethod protobuf-upgradable ((old protobuf-field) (new protobuf-field)) + (flet ((arity-upgradable (old new) + ;;--- We need to handle conversions between non-required fields and extensions + (or (eq old new) + (not (eq new :required)))) + (type-upgradable (old new) + ;;--- We need to handle conversions between embedded messages and bytes + (or + (string= old new) + ;; These varint types are all compatible + (and (member old '("int32" "uint32" "int64" "uint64" "bool") :test #'string=) + (member new '("int32" "uint32" "int64" "uint64" "bool") :test #'string=)) + ;; The two signed integer types are compatible + (and (member old '("sint32" "sint64") :test #'string=) + (member new '("sint32" "sint64") :test #'string=)) + ;; Fixed integers are compatible with each other + (and (member old '("fixed32" "sfixed32") :test #'string=) + (member new '("fixed32" "sfixed32") :test #'string=)) + (and (member old '("fixed64" "sfixed64") :test #'string=) + (member new '("fixed64" "sfixed64") :test #'string=)) + ;; Strings and bytes are compatible, assuming UTF-8 encoding + (and (member old '("string" "bytes") :test #'string=) + (member new '("string" "bytes") :test #'string=)))) + (default-upgradable (old new) + (declare (ignore old new)) + t)) + (and + ;; Are they named the same? + (string= (proto-name old) (proto-name new)) + ;; Do they have the same index? + (= (proto-index old) (proto-index new)) + ;; Is the type and arity upgradable + (arity-upgradable (proto-required old) (proto-required new)) + (type-upgradable (proto-type old) (proto-type new)) + (arity-upgradable (proto-required old) (proto-required new))))) + + +(defmethod protobuf-upgradable ((old protobuf-service) (new protobuf-service)) + (and + ;; Are they named the same? + (string= (proto-name old) (proto-name new)) + ;; Is every RPC in 'old' upgradable to an RPC in 'new'? + (loop for old-rpc in (proto-rpcs old) + as new-rpc = (find (proto-name old-rpc) (proto-rpcs new) + :key #'proto-name :test #'string=) + always (and new-rpc (protobuf-upgradable old-rpc new-rpc))))) + +(defmethod protobuf-upgradable ((old protobuf-rpc) (new protobuf-rpc)) + (and + ;; Are they named the same? + (string= (proto-name old) (proto-name new)) + ;; Are their inputs and outputs the same + (string= (proto-input-type old) (proto-input-type new)) + (string= (proto-output-type old) (proto-output-type new)))) -- 2.45.2