(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)
: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)
(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)
: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
(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
: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
(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
"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"
(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))
(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)))))
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;; 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))))
projects / cl-protobufs.git / commitdiff