upgradable.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 ;;; Can a version of a Protobufs schema be upgraded to a new version
  15
  16 (defgeneric protobuf-upgradable (old new &optional what)
  17   (:documentation
  18    "Returns true if and only if the old protobuf schema (enum, message, etc)
  19     can be upgraded to the new schema.
  20     If the schema is not upgradable, the second value is a list of warnings"))
  21
  22 (defvar *upgrade-warnings*)
  23 (defmacro upgrade-warn ((predicate old new) format-string &optional name)
  24   "Collect an upgrade warning into *upgrade-warnings*."
  25   (with-gensyms (vold vnew)
  26     `(let* ((,vold ,old)
  27             (,vnew ,new))
  28        (cond ((,predicate ,vold ,vnew)
  29               t)
  30              (t
  31               ;; Note that this returns the non-NIL value of *upgrade-warnings*,
  32               ;; so the upgradable check will continue to collect warnings
  33               (push (format nil ,format-string
  34                             ,@(if name (list name vold vnew) (list vold vnew)))
  35                     *upgrade-warnings*))))))
  36
  37 (defmethod protobuf-upgradable ((old protobuf) (new protobuf) &optional what)
  38   (declare (ignore what))
  39   (let ((*upgrade-warnings* ()))
  40     (and
  41      ;; Are they named the same?
  42      (upgrade-warn (string= (proto-name old) (proto-name new))
  43                    "Protobuf schema name changed from ~A to ~A")
  44      (upgrade-warn (string= (proto-package old) (proto-package new))
  45                    "Protobuf schema package changed from ~A to ~A")
  46      ;; Is every enum in 'old' upgradable to an enum in 'new'?
  47      (loop for old-enum in (proto-enums old)
  48            as new-enum = (find (proto-name old-enum) (proto-enums new)
  49                                :key #'proto-name :test #'string=)
  50            always (and new-enum (protobuf-upgradable old-enum new-enum)))
  51      ;; Is every message in 'old' upgradable to a message in 'new'?
  52      (loop for old-msg in (proto-messages old)
  53            as new-msg = (find (proto-name old-msg) (proto-messages new)
  54                               :key #'proto-name :test #'string=)
  55            always (and new-msg (protobuf-upgradable old-msg new-msg)))
  56      ;; Is every service in 'old' upgradable to a service in 'new'?
  57      (loop for old-svc in (proto-services old)
  58            as new-svc = (find (proto-name old-svc) (proto-services new)
  59                               :key #'proto-name :test #'string=)
  60            always (and new-svc (protobuf-upgradable old-svc new-svc))))
  61     (values (null *upgrade-warnings*) (nreverse *upgrade-warnings*))))
  62
  63
  64 (defmethod protobuf-upgradable ((old protobuf-enum) (new protobuf-enum) &optional what)
  65   (declare (ignore what))
  66   ;; No need to check that the names are equal, our caller did that already
  67   (loop for old-val in (proto-values old)
  68         as new-val = (find (proto-name old-val) (proto-values new)
  69                            :key #'proto-name :test #'string=)
  70         always (and new-val (protobuf-upgradable old-val new-val old))))
  71
  72 (defmethod protobuf-upgradable ((old protobuf-enum-value) (new protobuf-enum-value) &optional enum)
  73   ;; No need to check that the names are equal, our caller did that already
  74   ;; Do they have the same index?
  75   (upgrade-warn (= (proto-index old) (proto-index new))
  76                 "Enum index for ~A changed from ~D to ~D"
  77                 (format nil "~A within ~A" (proto-name old) (proto-name enum))))
  78
  79
  80 (defmethod protobuf-upgradable ((old protobuf-message) (new protobuf-message) &optional what)
  81   (declare (ignore what))
  82   ;; No need to check that the names are equal, our caller did that already
  83   (and
  84    ;; Is every enum in 'old' upgradable to an enum in 'new'?
  85    (loop for old-enum in (proto-enums old)
  86          as new-enum = (find (proto-name old-enum) (proto-enums new)
  87                              :key #'proto-name :test #'string=)
  88          always (and new-enum (protobuf-upgradable old-enum new-enum)))
  89    ;; Is every message in 'old' upgradable to a message in 'new'?
  90    (loop for old-msg in (proto-messages old)
  91          as new-msg = (find (proto-name old-msg) (proto-messages new)
  92                             :key #'proto-name :test #'string=)
  93          always (and new-msg (protobuf-upgradable old-msg new-msg)))
  94    ;; Is every required field in 'old' upgradable to a field in 'new'?
  95    ;; (Optional fields are safe to remove)
  96    (loop for old-fld in (proto-fields old)
  97          as new-fld = (find (proto-name old-fld) (proto-fields new)
  98                             :key #'proto-name :test #'string=)
  99          always (if new-fld
 100                   (protobuf-upgradable old-fld new-fld old)
 101                   ;; If there's no new field, the old one must not be required
 102                   (or (member (proto-required old-fld) '(:optional :repeated))
 103                       (push (format nil "Old field ~A was required, and is now missing"
 104                                     (proto-name old-fld))
 105                             *upgrade-warnings*))))))
 106
 107 (defmethod protobuf-upgradable ((old protobuf-field) (new protobuf-field) &optional message)
 108   (flet ((arity-upgradable (old new)
 109            ;;--- Handle conversions between non-required fields and extensions
 110            (or (eq old new)
 111                (not (eq new :required))))
 112          (type-upgradable (old new)
 113            ;;--- Handle conversions between embedded messages and bytes
 114            (or
 115             (string= old new)
 116             ;; These varint types are all compatible
 117             (and (member old '("int32" "uint32" "int64" "uint64" "bool") :test #'string=)
 118                  (member new '("int32" "uint32" "int64" "uint64" "bool") :test #'string=))
 119             ;; The two signed integer types are compatible
 120             (and (member old '("sint32" "sint64") :test #'string=)
 121                  (member new '("sint32" "sint64") :test #'string=))
 122             ;; Fixed integers are compatible with each other
 123             (and (member old '("fixed32" "sfixed32") :test #'string=)
 124                  (member new '("fixed32" "sfixed32") :test #'string=))
 125             (and (member old '("fixed64" "sfixed64") :test #'string=)
 126                  (member new '("fixed64" "sfixed64") :test #'string=))
 127             ;; Strings and bytes are compatible, assuming UTF-8 encoding
 128             (and (member old '("string" "bytes") :test #'string=)
 129                  (member new '("string" "bytes") :test #'string=))))
 130          (default-upgradable (old new)
 131            (declare (ignore old new))
 132            t))
 133     ;; No need to check that the names are equal, our caller did that already
 134     (and
 135      ;; Do they have the same index?
 136      (upgrade-warn (= (proto-index old) (proto-index new))
 137                    "Field index for ~A changed from ~D to ~D"
 138                    (format nil "~A within ~A" (proto-name old) (proto-name message)))
 139      ;; Are the arity and type upgradable?
 140      (upgrade-warn (arity-upgradable (proto-required old) (proto-required new))
 141                    "Arity of ~A, ~S, is not upgradable to ~S"
 142                    (format nil "~A within ~A" (proto-name old) (proto-name message)))
 143      (upgrade-warn (type-upgradable (proto-type old) (proto-type new))
 144                    "Type of ~A, ~A, is not upgradable to ~A"
 145                    (format nil "~A within ~A" (proto-name old) (proto-name message))))))
 146
 147
 148 (defmethod protobuf-upgradable ((old protobuf-service) (new protobuf-service) &optional what)
 149   (declare (ignore what))
 150   ;; No need to check that the names are equal, our caller did that already
 151   ;; Is every RPC in 'old' upgradable to an RPC in 'new'?
 152   (loop for old-rpc in (proto-rpcs old)
 153         as new-rpc = (find (proto-name old-rpc) (proto-rpcs new)
 154                            :key #'proto-name :test #'string=)
 155         always (and new-rpc (protobuf-upgradable old-rpc new-rpc old))))
 156
 157 (defmethod protobuf-upgradable ((old protobuf-rpc) (new protobuf-rpc) &optional service)
 158   (declare (ignore service))
 159   ;; No need to check that the names are equal, our caller did that already
 160   (and
 161    ;; Are their inputs and outputs the same?
 162    (upgrade-warn (string= (proto-input-name old) (proto-input-name new))
 163                  "Input type for ~A, ~A, is not upgradable to ~A" (proto-name old))
 164    (upgrade-warn (string= (proto-output-name old) (proto-output-name new))
 165                  "Output type for ~A, ~A, is not upgradable to ~A" (proto-name old))))