define-proto.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 ;;; Protocol buffer defining macros
  15
  16 ;; Define a schema named 'type', corresponding to a .proto file of that name
  17 (defmacro define-proto (type (&key name syntax package import optimize options documentation)
  18                         &body messages &environment env)
  19   "Define a schema named 'type', corresponding to a .proto file of that name.
  20    'name' can be used to override the defaultly generated Protobufs name.
  21    'syntax' and 'package' are as they would be in a .proto file.
  22    'imports' is a list of pathname strings to be imported.
  23    'options' is a property list, i.e., (\"key1\" \"val1\" \"key2\" \"val2\" ...).
  24
  25    The body consists of 'define-enum', 'define-message' or 'define-service' forms."
  26   (with-collectors ((enums collect-enum)
  27                     (msgs  collect-msg)
  28                     (svcs  collect-svc)
  29                     (forms collect-form))
  30     (dolist (msg messages)
  31       (assert (and (listp msg)
  32                    (member (car msg) '(define-enum define-message define-service))) ()
  33               "The body of ~S must be one of ~{~S~^ or ~}"
  34               'define-proto '(define-enum define-message define-service))
  35       ;; The macro-expander will return a form that consists
  36       ;; of 'progn' followed by a symbol naming what we've expanded
  37       ;; (define-enum, define-message, define-service), followed by
  38       ;; by a (optional) Lisp defining form (deftype, defclass),
  39       ;; followed by a form that creates the model object
  40       (destructuring-bind (&optional progn type model definers)
  41           (macroexpand-1 msg env)
  42         (assert (eq progn 'progn) ()
  43                 "The macroexpansion for ~S failed" msg)
  44         (map () #'collect-form definers)
  45         (ecase type
  46           ((define-enum)
  47            (collect-enum model))
  48           ((define-message)
  49            (collect-msg model))
  50           ((define-service)
  51            (collect-svc model)))))
  52     (let ((var  (fintern "*~A*" type))
  53           (name (or name (class-name->proto type)))
  54           (options (loop for (key val) on options by #'cddr
  55                          collect `(make-instance 'protobuf-option
  56                                     :name ,key
  57                                     :value ,val))))
  58       `(progn
  59          ,@forms
  60          (defvar ,var nil)
  61          (let ((old ,var)
  62                (protobuf (make-instance 'protobuf
  63                            :class    ',type
  64                            :name     ',name
  65                            :syntax   ,(or syntax "proto2")
  66                            :package  ,(if (stringp package) package (string-downcase (string package)))
  67                            :imports  ',(if (listp import) import (list import))
  68                            :options  (list ,@options)
  69                            :optimize ,optimize
  70                            :enums    (list ,@enums)
  71                            :messages (list ,@msgs)
  72                            :services (list ,@svcs)
  73                            :documentation ,documentation)))
  74            (when old
  75              (multiple-value-bind (upgradable warnings)
  76                  (protobuf-upgradable old protobuf)
  77                (unless upgradable
  78                  (protobufs-warn "The old schema for ~S (~A) can't be safely upgraded; proceeding anyway"
  79                                  ',type ',name)
  80                  (map () #'protobufs-warn warnings))))
  81            (setq ,var protobuf)
  82            ;; Record this schema under both its Lisp and its Protobufs name
  83            (setf (gethash ',type *all-protobufs*) protobuf)
  84            (setf (gethash ',name *all-protobufs*) protobuf)
  85            #+++ignore (
  86            ,@(when (eq optimize :speed)
  87                (mapcar (curry #'generate-object-size  protobuf) (proto-messages protobuf)))
  88            ,@(when (eq optimize :speed)
  89                (mapcar (curry #'generate-serializer   protobuf) (proto-messages protobuf)))
  90            ,@(when (eq optimize :speed)
  91                (mapcar (curry #'generate-deserializer protobuf) (proto-messages protobuf))) )
  92            protobuf)))))
  93
  94 ;; Define an enum type named 'type' and a Lisp 'deftype'
  95 (defmacro define-enum (type (&key name conc-name alias-for options documentation)
  96                        &body values)
  97   "Define an enum type named 'name' and a Lisp 'deftype'.
  98    'name' can be used to override the defaultly generated Protobufs enum name.
  99    'conc-name' will be used as the prefix to the Lisp enum names, if it's supplied.
 100    If 'alias-for' is given, no Lisp type is defined. Instead, the enum will be
 101    used as an alias for an enum type that already exists in Lisp.
 102    'options' is a set of keyword/value pairs, both of which are strings.
 103
 104    The body consists of the enum values in the form 'name' or (name index)."
 105   (with-collectors ((vals  collect-val)
 106                     (evals collect-eval)
 107                     (forms collect-form))
 108     (let ((index 0))
 109       (dolist (val values)
 110         (let* ((idx  (if (listp val) (second val) (incf index)))
 111                (name (if (listp val) (first val)  val))
 112                (val-name  (kintern (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
 113                (enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))))
 114           (collect-val val-name)
 115           (collect-eval `(make-instance 'protobuf-enum-value
 116                            :name  ,(enum-name->proto enum-name)
 117                            :index ,idx
 118                            :value ,val-name)))))
 119
 120     (if alias-for
 121       ;; If we've got an alias, define a a type that is the subtype of
 122       ;; the Lisp enum so that typep and subtypep work
 123       (unless (eq type alias-for)
 124         (collect-form `(deftype ,type () ',alias-for)))
 125       ;; If no alias, define the Lisp enum type now
 126       (collect-form `(deftype ,type () '(member ,@vals))))
 127     (let ((name (or name (class-name->proto type)))
 128           (options (loop for (key val) on options by #'cddr
 129                          collect `(make-instance 'protobuf-option
 130                                     :name ,key
 131                                     :value ,val))))
 132       `(progn
 133          define-enum
 134          (make-instance 'protobuf-enum
 135            :class  ',type
 136            :name   ',name
 137            :alias-for ',alias-for
 138            :options (list ,@options)
 139            :values  (list ,@evals)
 140            :documentation ,documentation)
 141          ,forms))))
 142
 143 ;; Define a message named 'name' and a Lisp 'defclass'
 144 (defmacro define-message (type (&key name conc-name alias-for options documentation)
 145                           &body fields &environment env)
 146   "Define a message named 'type' and a Lisp 'defclass'.
 147    'name' can be used to override the defaultly generated Protobufs message name.
 148    The body consists of fields, or 'define-enum' or 'define-message' forms.
 149    'conc-name' will be used as the prefix to the Lisp slot accessors, if it's supplied.
 150    If 'alias-for' is given, no Lisp class is defined. Instead, the message will be
 151    used as an alias for a class that already exists in Lisp. This feature is intended
 152    to be used to defined messages that will be serialized from existing Lisp classes;
 153    unless you get the slot names or readers exactly right for each field, it will be
 154    the case that trying to (de)serialize into a Lisp object won't work.
 155    'options' is a set of keyword/value pairs, both of which are strings.
 156
 157    Fields take the form (slot &key type name default reader)
 158    'slot' can be either a symbol giving the field name, or a list whose
 159    first element is the slot name and whose second element is the index.
 160    'type' is the type of the slot.
 161    'name' can be used to override the defaultly generated Protobufs field name.
 162    'default' is the default value for the slot.
 163    'reader' is a Lisp slot reader function to use to get the value, instead of
 164    using 'slot-value'; this is often used when aliasing an existing class."
 165   (with-collectors ((enums collect-enum)
 166                     (msgs  collect-msg)
 167                     (flds  collect-field)
 168                     (slots collect-slot)
 169                     (forms collect-form))
 170     (let ((index 0))
 171       (declare (type fixnum index))
 172       (dolist (fld fields)
 173         (case (car fld)
 174           ((define-enum define-message define-extension)
 175            (destructuring-bind (&optional progn type model definers)
 176                (macroexpand-1 fld env)
 177              (assert (eq progn 'progn) ()
 178                      "The macroexpansion for ~S failed" fld)
 179              (map () #'collect-form definers)
 180              (ecase type
 181                ((define-enum)
 182                 (collect-enum model))
 183                ((define-message)
 184                 (collect-msg model))
 185                ((define-extension)
 186                 (collect-msg model)))))
 187           (otherwise
 188            (when (i= index 18999)                       ;skip over the restricted range
 189              (setq index 19999))
 190            (destructuring-bind (slot &key type default reader name) fld
 191              (let* ((idx  (if (listp slot) (second slot) (iincf index)))
 192                     (slot (if (listp slot) (first slot) slot))
 193                     (reqd (clos-type-to-protobuf-required type))
 194                     (accessor (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
 195                                       (symbol-package slot))))
 196                (multiple-value-bind (ptype pclass)
 197                    (clos-type-to-protobuf-type type)
 198                  (unless alias-for
 199                    (collect-slot `(,slot :type ,type
 200                                          :accessor ,accessor
 201                                          :initarg ,(kintern (symbol-name slot))
 202                                          ,@(and default (list :initform default)))))
 203                  (collect-field `(make-instance 'protobuf-field
 204                                    :name  ,(or name (slot-name->proto slot))
 205                                    :type  ,ptype
 206                                    :class ',pclass
 207                                    :required ,reqd
 208                                    :index  ,idx
 209                                    :value  ',slot
 210                                    :reader ',reader
 211                                    :default ,(and default (format nil "~A" default))
 212                                    :packed  ,(and (eq reqd :repeated)
 213                                                   (packed-type-p pclass)))))))))))
 214     (if alias-for
 215       ;; If we've got an alias, define a a type that is the subtype of
 216       ;; the Lisp class that typep and subtypep work
 217       (unless (or (eq type alias-for) (find-class type nil))
 218         (collect-form `(deftype ,type () ',alias-for)))
 219       ;; If no alias, define the class now
 220       (collect-form `(defclass ,type () (,@slots))))
 221     (let ((name (or name (class-name->proto type)))
 222           (options (loop for (key val) on options by #'cddr
 223                          collect `(make-instance 'protobuf-option
 224                                     :name ,key
 225                                     :value ,val))))
 226       `(progn
 227          define-message
 228          (make-instance 'protobuf-message
 229            :class ',type
 230            :name  ',name
 231            :alias-for ',alias-for
 232            :conc-name ,(and conc-name (string conc-name))
 233            :options  (list ,@options)
 234            :enums    (list ,@enums)
 235            :messages (list ,@msgs)
 236            :fields   (list ,@flds)
 237            :documentation ,documentation)
 238          ,forms))))
 239
 240 (defmacro define-extension (from to)
 241   "Define an extension range within a message.
 242    The \"body\" is the start and end of the range, both inclusive."
 243   `(progn
 244      define-extension
 245      (make-instance 'protobuf-extension
 246        :from ,from
 247        :to   ,to)
 248      ()))
 249
 250 ;; Define a service named 'type' with generic functions declared for
 251 ;; each of the RPCs within the service
 252 (defmacro define-service (type (&key name options documentation)
 253                           &body rpc-specs)
 254   "Define a service named 'type' and Lisp 'defgeneric' for all its RPCs.
 255    'name' can be used to override the defaultly generated Protobufs service name.
 256    'options' is a set of keyword/value pairs, both of which are strings.
 257
 258    The body is a set of RPC specs of the form (name (input-type output-type) &key options).
 259    'input-type' and 'output-type' may also be of the form (type &key name)."
 260   (with-collectors ((rpcs collect-rpc)
 261                     (forms collect-form))
 262     (dolist (rpc rpc-specs)
 263       (destructuring-bind (function (input-type output-type) &key name options) rpc
 264         (let* ((input-name (and (listp input-type)
 265                                 (getf (cdr input-type) :name)))
 266                (input-type (if (listp input-type) (car input-type) input-type))
 267                (output-name (and (listp output-type)
 268                                  (getf (cdr output-type) :name)))
 269                (output-type (if (listp output-type) (car output-type) output-type))
 270                (options (loop for (key val) on options by #'cddr
 271                               collect `(make-instance 'protobuf-option
 272                                          :name ,key
 273                                          :value ,val))))
 274           (collect-rpc `(make-instance 'protobuf-rpc
 275                           :class ',function
 276                           :name  ',(or name (class-name->proto function))
 277                           :input-type  ',input-type
 278                           :input-name  ',(or input-name (class-name->proto input-type))
 279                           :output-type ',output-type
 280                           :output-name ',(or output-name (class-name->proto output-type))
 281                           :options (list ,@options)))
 282           (let ((vcontroller (intern (symbol-name 'controller) (symbol-package function)))
 283                 (vcallback   (intern (symbol-name 'callback) (symbol-package function))))
 284             ;;--- Is this really what the stub's signature should be?
 285             (collect-form `(defgeneric ,function (,vcontroller ,input-type &optional ,vcallback)
 286                              (declare (values ,output-type))))))))
 287     (let ((name (or name (class-name->proto type)))
 288           (options (loop for (key val) on options by #'cddr
 289                          collect `(make-instance 'protobuf-option
 290                                     :name ,key
 291                                     :value ,val))))
 292       `(progn
 293          define-service
 294          (make-instance 'protobuf-service
 295            :class ',type
 296            :name  ',name
 297            :options  (list ,@options)
 298            :rpcs (list ,@rpcs)
 299            :documentation ,documentation)
 300          ,forms))))
 301
 302 \f
 303 ;;; Ensure everything in a Protobufs schema is defined
 304
 305 (defvar *undefined-messages*)
 306
 307 ;; A very useful tool during development...
 308 (defun ensure-all-protobufs ()
 309   (let ((protos (sort
 310                  (delete-duplicates
 311                   (loop for p being the hash-values of *all-protobufs*
 312                         collect p))
 313                  #'string< :key #'proto-name)))
 314     (mapcan #'ensure-protobuf protos)))
 315
 316 (defmethod ensure-protobuf ((proto protobuf))
 317   "Ensure that all of the types are defined in the Protobufs schema 'proto'.
 318    This returns two values:
 319     - A list whose elements are (<undefined-type> \"message:field\" ...)
 320     - The accumulated warnings table that has the same information as objects."
 321   (let ((*undefined-messages* (make-hash-table))
 322         (trace (list proto)))
 323     (map () (curry #'ensure-message trace) (proto-messages proto))
 324     (map () (curry #'ensure-service trace) (proto-services proto))
 325     (loop for type being the hash-keys of *undefined-messages*
 326             using (hash-value things)
 327           collect (list* type
 328                          (mapcar #'(lambda (thing)
 329                                      (format nil "~A:~A" (proto-name (car thing)) (proto-name (cdr thing))))
 330                                  things)) into warnings
 331           finally (return (values warnings *undefined-messages*)))))
 332
 333 (defmethod ensure-message (trace (message protobuf-message))
 334   (let ((trace (cons message trace)))
 335     (map () (curry #'ensure-message trace) (proto-messages message))
 336     (map () (curry #'ensure-field trace message) (proto-fields message))))
 337
 338 (defmethod ensure-field (trace message (field protobuf-field))
 339   (ensure-type trace message field (proto-class field)))
 340
 341 (defmethod ensure-service (trace (service protobuf-service))
 342   (map () (curry #'ensure-rpc trace service) (proto-rpcs service)))
 343
 344 (defmethod ensure-rpc (trace service (rpc protobuf-rpc))
 345   (ensure-type trace service rpc (proto-input-type rpc))
 346   (ensure-type trace service rpc (proto-output-type rpc)))
 347
 348 ;; 'message' and 'field' can be a message and a field or a service and an RPC
 349 (defun ensure-type (trace message field type)
 350   (unless (keywordp type)
 351     (let ((msg (loop for p in trace
 352                      thereis (or (find-message p type)
 353                                  (find-enum p type)))))
 354       (unless msg
 355         (push (cons message field) (gethash type *undefined-messages*))))))