upgradable.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Can a version of a Protobufs schema be upgraded to a new version
  15
  16 (defvar *upgrade-warnings* nil
  17   "Bound to the list of upgrade warning messages.")
  18
  19 (defun upgrade-warn (format-string &rest format-args)
  20   "Collect an upgrade warning into *upgrade-warnings*.
  21    Returns the list of warnings."
  22   (push (apply #'format nil format-string format-args) *upgrade-warnings*))
  23
  24 (defmacro upgrade-assert ((predicate old new) format-string &optional name)
  25   "Assert that the condition is true, otherwise issue an upgrade warning."
  26   (with-gensyms (vold vnew)
  27     `(let* ((,vold ,old)
  28             (,vnew ,new))
  29        (cond ((,predicate ,vold ,vnew)
  30               t)
  31              (t
  32               ;; Note that this returns the non-NIL value of *upgrade-warnings*,
  33               ;; so the upgradable check will continue to collect warnings
  34               (upgrade-warn ,format-string ,@(if name (list name vold vnew) (list vold vnew))))))))
  35
  36
  37 (defgeneric schema-upgradable (old new &optional old-parent new-parent)
  38   (:documentation
  39    "Returns true if and only if the old Protobufs schema can be upgraded to
  40     the new schema.
  41     'old' is the old object (schema, enum, message, etc), 'new' is the new one.
  42     'old-parent' is the \"parent\" of 'old', 'new-parent' is the parent of 'new'.
  43     If the schema is not upgradable, the second value is a list of warnings."))
  44
  45 (defmethod schema-upgradable ((old protobuf-schema) (new protobuf-schema)
  46                               &optional old-parent new-parent)
  47   (declare (ignore old-parent new-parent))
  48   (let ((*upgrade-warnings* ()))
  49     (and
  50      ;; Are they named the same?
  51      (upgrade-assert (string= (proto-name old) (proto-name new))
  52                      "Protobuf schema name changed from '~A' to '~A'")
  53      (upgrade-assert (string= (proto-package old) (proto-package new))
  54                      "Protobuf schema package changed from '~A' to '~A'")
  55      ;; Is every enum in 'old' upgradable to an enum in 'new'?
  56      (loop for old-enum in (proto-enums old)
  57            as new-enum = (find (proto-name old-enum) (proto-enums new)
  58                                :key #'proto-name :test #'string=)
  59            always (and new-enum (schema-upgradable old-enum new-enum old new)))
  60      ;; Is every message in 'old' upgradable to a message in 'new'?
  61      (loop for old-msg in (proto-messages old)
  62            as new-msg = (find (proto-name old-msg) (proto-messages new)
  63                               :key #'proto-name :test #'string=)
  64            always (and new-msg (schema-upgradable old-msg new-msg old new)))
  65      ;; Is every service in 'old' upgradable to a service in 'new'?
  66      (loop for old-svc in (proto-services old)
  67            as new-svc = (find (proto-name old-svc) (proto-services new)
  68                               :key #'proto-name :test #'string=)
  69            always (and new-svc (schema-upgradable old-svc new-svc old new))))
  70     (values (null *upgrade-warnings*) (nreverse *upgrade-warnings*))))
  71
  72
  73 (defmethod schema-upgradable ((old protobuf-enum) (new protobuf-enum)
  74                               &optional old-parent new-parent)
  75   (declare (ignore old-parent new-parent))
  76   ;; No need to check that the names are equal, our caller did that already
  77   (loop for old-val in (proto-values old)
  78         as new-val = (find (proto-name old-val) (proto-values new)
  79                            :key #'proto-name :test #'string=)
  80         always (and new-val (schema-upgradable old-val new-val old new))))
  81
  82 (defmethod schema-upgradable ((old protobuf-enum-value) (new protobuf-enum-value)
  83                               &optional old-enum new-enum)
  84   (declare (ignore new-enum))
  85   ;; No need to check that the names are equal, our caller did that already
  86   ;; Do they have the same index?
  87   (upgrade-assert (= (proto-index old) (proto-index new))
  88                   "Enum index for '~A' changed from ~D to ~D"
  89                   (format nil "~A.~A" (proto-name old-enum) (proto-name old))))
  90
  91
  92 (defmethod schema-upgradable ((old protobuf-message) (new protobuf-message)
  93                               &optional old-parent new-parent)
  94   (declare (ignore old-parent new-parent))
  95   ;; No need to check that the names are equal, our caller did that already
  96   (and
  97    ;; Is every enum in 'old' upgradable to an enum in 'new'?
  98    (loop for old-enum in (proto-enums old)
  99          as new-enum = (find (proto-name old-enum) (proto-enums new)
 100                              :key #'proto-name :test #'string=)
 101          always (and new-enum (schema-upgradable old-enum new-enum old new)))
 102    ;; Is every message in 'old' upgradable to a message in 'new'?
 103    (loop for old-msg in (proto-messages old)
 104          as new-msg = (find (proto-name old-msg) (proto-messages new)
 105                             :key #'proto-name :test #'string=)
 106          always (and new-msg (schema-upgradable old-msg new-msg old new)))
 107    ;; Is every required field in 'old' upgradable to a field in 'new'?
 108    ;; (Optional fields are safe to remove)
 109    (loop for old-fld in (proto-fields old)
 110          as new-fld = (find (proto-name old-fld) (proto-fields new)
 111                             :key #'proto-name :test #'string=)
 112          always (if new-fld
 113                   (schema-upgradable old-fld new-fld old new)
 114                   ;; If there's no new field, the old one must not be required
 115                   (or (member (proto-required old-fld) '(:optional :repeated))
 116                       (upgrade-warn "Old field '~A.~A' was required, and is now missing"
 117                                     (proto-name old) (proto-name old-fld)))))))
 118
 119 (defmethod schema-upgradable ((old protobuf-field) (new protobuf-field)
 120                               &optional old-message new-message)
 121   (flet ((arity-upgradable (old-arity new-arity)
 122            (or (eq old-arity new-arity)
 123                ;; Don't add new required fields
 124                (not (eq new-arity :required))
 125                ;; Optional fields and extensions are compatible
 126                (and (eq old-arity :optional)
 127                     (index-within-extensions-p (proto-index new) new-message))
 128                (and (eq new-arity :optional)
 129                     (index-within-extensions-p (proto-index old) old-message))))
 130          (type-upgradable (old-type new-type)
 131            ;;--- Handle conversions between embedded messages and bytes
 132            (or
 133             (string= old-type new-type)
 134             ;; These varint types are all compatible
 135             (and (member old-type '("int32" "uint32" "int64" "uint64" "bool") :test #'string=)
 136                  (member new-type '("int32" "uint32" "int64" "uint64" "bool") :test #'string=))
 137             ;; The two signed integer types are compatible
 138             (and (member old-type '("sint32" "sint64") :test #'string=)
 139                  (member new-type '("sint32" "sint64") :test #'string=))
 140             ;; Fixed integers are compatible with each other
 141             (and (member old-type '("fixed32" "sfixed32") :test #'string=)
 142                  (member new-type '("fixed32" "sfixed32") :test #'string=))
 143             (and (member old-type '("fixed64" "sfixed64") :test #'string=)
 144                  (member new-type '("fixed64" "sfixed64") :test #'string=))
 145             ;; Strings and bytes are compatible, assuming UTF-8 encoding
 146             (and (member old-type '("string" "bytes") :test #'string=)
 147                  (member new-type '("string" "bytes") :test #'string=)))))
 148     ;; No need to check that the names are equal, our caller did that already
 149     (and
 150      ;; Do they have the same index?
 151      (upgrade-assert (= (proto-index old) (proto-index new))
 152                      "Field index for '~A' changed from ~D to ~D"
 153                      (format nil "~A.~A" (proto-name old-message) (proto-name old)))
 154      ;; Are the arity and type upgradable?
 155      (upgrade-assert (arity-upgradable (proto-required old) (proto-required new))
 156                      "Arity of ~A, ~S, is not upgradable to ~S"
 157                      (format nil  "~A.~A" (proto-name old-message) (proto-name old)))
 158      (upgrade-assert (type-upgradable (proto-type old) (proto-type new))
 159                      "Type of '~A', ~A, is not upgradable to ~A"
 160                      (format nil  "~A.~A" (proto-name old-message) (proto-name old)))
 161      ;; Is the default the same?
 162      (upgrade-assert (equal (proto-default old) (proto-default new))
 163                      "Old default for ~A, ~S, is not equal to new default ~S"
 164                      (format nil  "~A.~A" (proto-name old-message) (proto-name old))))))
 165
 166
 167 (defmethod schema-upgradable ((old protobuf-service) (new protobuf-service)
 168                               &optional old-parent new-parent)
 169   (declare (ignore old-parent new-parent))
 170   ;; No need to check that the names are equal, our caller did that already
 171   ;; Is every method in 'old' upgradable to a method in 'new'?
 172   (loop for old-method in (proto-methods old)
 173         as new-method = (find (proto-name old-method) (proto-methods new)
 174                               :key #'proto-name :test #'string=)
 175         always (and new-method (schema-upgradable old-method new-method old new))))
 176
 177 (defmethod schema-upgradable ((old protobuf-method) (new protobuf-method)
 178                               &optional old-service new-service)
 179   (declare (ignore new-service))
 180   ;; No need to check that the names are equal, our caller did that already
 181   (and
 182    ;; Are their inputs and outputs the same?
 183    (upgrade-assert (string= (proto-input-name old) (proto-input-name new))
 184                    "Input type for ~A, ~A, is not upgradable to ~A"
 185                    (format nil  "~A.~A" (proto-name old-service) (proto-name old)))
 186    (upgrade-assert (string= (proto-output-name old) (proto-output-name new))
 187                    "Output type for ~A, ~A, is not upgradable to ~A"
 188                    (format nil  "~A.~A" (proto-name old-service) (proto-name old)))))
 189
 190 \f
 191 ;;; Are two protobuf schemas equal?
 192
 193 ;; This is useful for testing purposes, but not much else
 194 (defgeneric schemas-equal (schema1 proto2)
 195   (:documentation
 196    "Returns true if and only if the two Protobufs schemas are equal."))
 197
 198 ;; These methods are pretty similar to the 'schema-upgradable' methods above
 199 (defmethod schemas-equal ((schema1 protobuf-schema) (schema2 protobuf-schema))
 200   (and
 201    ;; If the name(s) are null, don't worry about them
 202    (or (null (proto-class schema1)) (null (proto-class schema2))
 203        (eql (proto-class schema1) (proto-class schema2)))
 204    (or (null (proto-name schema1)) (null (proto-name schema2))
 205        (equal (proto-name schema1) (proto-name schema2)))
 206    (equal (proto-syntax schema1) (proto-syntax schema2))
 207    (equal (proto-package schema1) (proto-package schema2))
 208    (equal (proto-lisp-package schema1) (proto-lisp-package schema2))
 209    (equal (proto-imports schema1) (proto-imports schema2))
 210    (= (length (proto-options schema1)) (length (proto-options schema2)))
 211    (loop for option1 in (proto-options schema1)
 212          as option2 = (find (proto-name option1) (proto-options schema2)
 213                             :key #'proto-name :test #'string=)
 214          always (and option2 (schemas-equal option1 option2)))
 215    (= (length (proto-enums schema1)) (length (proto-enums schema2)))
 216    (loop for enum1 in (proto-enums schema1)
 217          as enum2 = (find (proto-name enum1) (proto-enums schema2)
 218                           :key #'proto-name :test #'string=)
 219          always (and enum2 (schemas-equal enum1 enum2)))
 220    (= (length (proto-messages schema1)) (length (proto-messages schema2)))
 221    (loop for msg1 in (proto-messages schema1)
 222          as msg2 = (find-if #'(lambda (msg2)
 223                                 (and (string= (proto-name msg1) (proto-name msg2))
 224                                      (eql (proto-message-type msg1) (proto-message-type msg2))))
 225                             (proto-messages schema2))
 226          always (and msg2 (schemas-equal msg1 msg2)))
 227    (= (length (proto-services schema1)) (length (proto-services schema2)))
 228    (loop for svc1 in (proto-services schema1)
 229          as svc2 = (find (proto-name svc1) (proto-services schema2)
 230                          :key #'proto-name :test #'string=)
 231          always (and svc2 (schemas-equal svc1 svc2)))))
 232
 233 (defmethod schemas-equal ((option1 protobuf-option) (option2 protobuf-option))
 234   (and
 235    (string= (proto-name option1) (proto-name option2))
 236    (equal   (proto-value option1) (proto-value option2))
 237    (equal   (proto-type option1) (proto-type option2))))
 238
 239 (defmethod schemas-equal ((enum1 protobuf-enum) (enum2 protobuf-enum))
 240   (and
 241    (eql   (proto-class enum1) (proto-class enum2))
 242    (equal (proto-name enum1) (proto-name enum2))
 243    (equal (proto-alias-for enum1) (proto-alias-for enum2))
 244    (= (length (proto-options enum1)) (length (proto-options enum2)))
 245    (loop for option1 in (proto-options enum1)
 246          as option2 = (find (proto-name option1) (proto-options enum2)
 247                             :key #'proto-name :test #'string=)
 248          always (and option2 (schemas-equal option1 option2)))
 249    (= (length (proto-values enum1)) (length (proto-values enum2)))
 250    (loop for val1 in (proto-values enum1)
 251          as val2 = (find (proto-name val1) (proto-values enum2)
 252                          :key #'proto-name :test #'string=)
 253          always (and val2 (schemas-equal val1 val2)))))
 254
 255 (defmethod schemas-equal ((value1 protobuf-enum-value) (value2 protobuf-enum-value))
 256   (and
 257    (eql   (proto-class value1) (proto-class value2))
 258    (equal (proto-name value1) (proto-name value2))
 259    (eql   (proto-index value1) (proto-index value2))
 260    (equal (proto-value value1) (proto-value value2))))
 261
 262 (defmethod schemas-equal ((message1 protobuf-message) (message2 protobuf-message))
 263   (and
 264    (eql   (proto-class message1) (proto-class message2))
 265    (equal (proto-name message1) (proto-name message2))
 266    (equal (proto-alias-for message1) (proto-alias-for message2))
 267    (eql   (proto-message-type message1) (proto-message-type message2))
 268    (= (length (proto-options message1)) (length (proto-options message2)))
 269    (loop for option1 in (proto-options message1)
 270          as option2 = (find (proto-name option1) (proto-options message2)
 271                             :key #'proto-name :test #'string=)
 272          always (and option2 (schemas-equal option1 option2)))
 273    (= (length (proto-enums message1)) (length (proto-enums message2)))
 274    (loop for enum1 in (proto-enums message1)
 275          as enum2 = (find (proto-name enum1) (proto-enums message2)
 276                           :key #'proto-name :test #'string=)
 277          always (and enum2 (schemas-equal enum1 enum2)))
 278    (= (length (proto-messages message1)) (length (proto-messages message2)))
 279    (loop for msg1 in (proto-messages message1)
 280          as msg2 = (find-if #'(lambda (msg2)
 281                                 (and (string= (proto-name msg1) (proto-name msg2))
 282                                      (eql (proto-message-type msg1) (proto-message-type msg2))))
 283                             (proto-messages message2))
 284          always (and msg2 (schemas-equal msg1 msg2)))
 285    (= (length (proto-fields message1)) (length (proto-fields message2)))
 286    (loop for fld1 in (proto-fields message1)
 287          as fld2 = (find (proto-name fld1) (proto-fields message2)
 288                          :key #'proto-name :test #'string=)
 289          always (and fld2 (schemas-equal fld1 fld2)))
 290    (= (length (proto-extensions message1)) (length (proto-extensions message2)))
 291    (loop for ext1 in (proto-extensions message1)
 292          for ext2 in (proto-extensions message2)
 293          always (schemas-equal ext1 ext2))))
 294
 295 (defmethod schemas-equal ((field1 protobuf-field) (field2 protobuf-field))
 296   (and
 297    (eql   (proto-class field1) (proto-class field2))
 298    (equal (proto-name field1) (proto-name field2))
 299    (equal (proto-type field1) (proto-type field2))
 300    (eql   (proto-required field1) (proto-required field2))
 301    (eql   (proto-value field1) (proto-value field2))
 302    (eql   (proto-index field1) (proto-index field2))
 303    (eql   (proto-reader field1) (proto-reader field2))
 304    (eql   (proto-writer field1) (proto-writer field2))
 305    (equal (proto-default field1) (proto-default field2))
 306    (eql   (proto-packed field1) (proto-packed field2))
 307    (eql   (proto-message-type field1) (proto-message-type field2))
 308    (= (length (proto-options field1)) (length (proto-options field2)))
 309    (loop for option1 in (proto-options field1)
 310          as option2 = (find (proto-name option1) (proto-options field2)
 311                             :key #'proto-name :test #'string=)
 312          always (and option2 (schemas-equal option1 option2)))))
 313
 314 (defmethod schemas-equal ((extension1 protobuf-extension) (extension2 protobuf-extension))
 315   (and
 316    (eql (proto-extension-from extension1) (proto-extension-from extension2))
 317    (eql (proto-extension-to extension1) (proto-extension-to extension2))))
 318
 319 (defmethod schemas-equal ((service1 protobuf-service) (service2 protobuf-service))
 320   (and
 321    (eql   (proto-class service1) (proto-class service2))
 322    (equal (proto-name service1) (proto-name service2))
 323    (= (length (proto-options service1)) (length (proto-options service2)))
 324    (loop for option1 in (proto-options service1)
 325          as option2 = (find (proto-name option1) (proto-options service2)
 326                             :key #'proto-name :test #'string=)
 327          always (and option2 (schemas-equal option1 option2)))
 328    (= (length (proto-methods service1)) (length (proto-methods service2)))
 329    (loop for method1 in (proto-methods service1)
 330          as method2 = (find (proto-name method1) (proto-methods service2)
 331                             :key #'proto-name :test #'string=)
 332          always (and method2 (schemas-equal method1 method2)))))
 333
 334 (defmethod schemas-equal ((method1 protobuf-method) (method2 protobuf-method))
 335   (and
 336    (eql   (proto-class method1) (proto-class method2))
 337    (equal (proto-name method1) (proto-name method2))
 338    (eql   (proto-input-type method1) (proto-input-type method2))
 339    (eql   (proto-output-type method1) (proto-output-type method2))
 340    (equal (proto-input-name method1) (proto-input-name method2))
 341    (equal (proto-output-name method1) (proto-output-name method2))
 342    (eql   (proto-index method1) (proto-index method2))
 343    (= (length (proto-options method1)) (length (proto-options method2)))
 344    (loop for option1 in (proto-options method1)
 345          as option2 = (find (proto-name option1) (proto-options method2)
 346                             :key #'proto-name :test #'string=)
 347          always (and option2 (schemas-equal option1 option2)))))