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                                          ,@(cond ((and (null default) (eq reqd :repeated))
 203                                                   `(:initform ()))
 204                                                  ((and (null default) (eq reqd :optional))
 205                                                   `(:initform nil))
 206                                                  (default
 207                                                    `(:initform ,default))))))
 208                  (collect-field `(make-instance 'protobuf-field
 209                                    :name  ,(or name (slot-name->proto slot))
 210                                    :type  ,ptype
 211                                    :class ',pclass
 212                                    :required ,reqd
 213                                    :index  ,idx
 214                                    :value  ',slot
 215                                    :reader ',reader
 216                                    :default ,(and default (format nil "~A" default))
 217                                    :packed  ,(and (eq reqd :repeated)
 218                                                   (packed-type-p pclass)))))))))))
 219     (if alias-for
 220       ;; If we've got an alias, define a a type that is the subtype of
 221       ;; the Lisp class that typep and subtypep work
 222       (unless (or (eq type alias-for) (find-class type nil))
 223         (collect-form `(deftype ,type () ',alias-for)))
 224       ;; If no alias, define the class now
 225       (collect-form `(defclass ,type () (,@slots))))
 226     (let ((name (or name (class-name->proto type)))
 227           (options (loop for (key val) on options by #'cddr
 228                          collect `(make-instance 'protobuf-option
 229                                     :name ,key
 230                                     :value ,val))))
 231       `(progn
 232          define-message
 233          (make-instance 'protobuf-message
 234            :class ',type
 235            :name  ',name
 236            :alias-for ',alias-for
 237            :conc-name ,(and conc-name (string conc-name))
 238            :options  (list ,@options)
 239            :enums    (list ,@enums)
 240            :messages (list ,@msgs)
 241            :fields   (list ,@flds)
 242            :documentation ,documentation)
 243          ,forms))))
 244
 245 (defmacro define-extension (from to)
 246   "Define an extension range within a message.
 247    The \"body\" is the start and end of the range, both inclusive."
 248   `(progn
 249      define-extension
 250      (make-instance 'protobuf-extension
 251        :from ,from
 252        :to   ,to)
 253      ()))
 254
 255 ;; Define a service named 'type' with generic functions declared for
 256 ;; each of the RPCs within the service
 257 (defmacro define-service (type (&key name options documentation)
 258                           &body rpc-specs)
 259   "Define a service named 'type' and Lisp 'defgeneric' for all its RPCs.
 260    'name' can be used to override the defaultly generated Protobufs service name.
 261    'options' is a set of keyword/value pairs, both of which are strings.
 262
 263    The body is a set of RPC specs of the form (name (input-type output-type) &key options).
 264    'input-type' and 'output-type' may also be of the form (type &key name)."
 265   (with-collectors ((rpcs collect-rpc)
 266                     (forms collect-form))
 267     (dolist (rpc rpc-specs)
 268       (destructuring-bind (function (input-type output-type) &key name options) rpc
 269         (let* ((input-name (and (listp input-type)
 270                                 (getf (cdr input-type) :name)))
 271                (input-type (if (listp input-type) (car input-type) input-type))
 272                (output-name (and (listp output-type)
 273                                  (getf (cdr output-type) :name)))
 274                (output-type (if (listp output-type) (car output-type) output-type))
 275                (options (loop for (key val) on options by #'cddr
 276                               collect `(make-instance 'protobuf-option
 277                                          :name ,key
 278                                          :value ,val))))
 279           (collect-rpc `(make-instance 'protobuf-rpc
 280                           :class ',function
 281                           :name  ',(or name (class-name->proto function))
 282                           :input-type  ',input-type
 283                           :input-name  ',(or input-name (class-name->proto input-type))
 284                           :output-type ',output-type
 285                           :output-name ',(or output-name (class-name->proto output-type))
 286                           :options (list ,@options)))
 287           (let ((vcontroller (intern (symbol-name 'controller) (symbol-package function)))
 288                 (vcallback   (intern (symbol-name 'callback) (symbol-package function))))
 289             ;;--- Is this really what the stub's signature should be?
 290             (collect-form `(defgeneric ,function (,vcontroller ,input-type &optional ,vcallback)
 291                              (declare (values ,output-type))))))))
 292     (let ((name (or name (class-name->proto type)))
 293           (options (loop for (key val) on options by #'cddr
 294                          collect `(make-instance 'protobuf-option
 295                                     :name ,key
 296                                     :value ,val))))
 297       `(progn
 298          define-service
 299          (make-instance 'protobuf-service
 300            :class ',type
 301            :name  ',name
 302            :options  (list ,@options)
 303            :rpcs (list ,@rpcs)
 304            :documentation ,documentation)
 305          ,forms))))
 306
 307 \f
 308 ;;; Ensure everything in a Protobufs schema is defined
 309
 310 (defvar *undefined-messages*)
 311
 312 ;; A very useful tool during development...
 313 (defun ensure-all-protobufs ()
 314   (let ((protos (sort
 315                  (delete-duplicates
 316                   (loop for p being the hash-values of *all-protobufs*
 317                         collect p))
 318                  #'string< :key #'proto-name)))
 319     (mapcan #'ensure-protobuf protos)))
 320
 321 (defmethod ensure-protobuf ((proto protobuf))
 322   "Ensure that all of the types are defined in the Protobufs schema 'proto'.
 323    This returns two values:
 324     - A list whose elements are (<undefined-type> \"message:field\" ...)
 325     - The accumulated warnings table that has the same information as objects."
 326   (let ((*undefined-messages* (make-hash-table))
 327         (trace (list proto)))
 328     (map () (curry #'ensure-message trace) (proto-messages proto))
 329     (map () (curry #'ensure-service trace) (proto-services proto))
 330     (loop for type being the hash-keys of *undefined-messages*
 331             using (hash-value things)
 332           collect (list* type
 333                          (mapcar #'(lambda (thing)
 334                                      (format nil "~A:~A" (proto-name (car thing)) (proto-name (cdr thing))))
 335                                  things)) into warnings
 336           finally (return (values warnings *undefined-messages*)))))
 337
 338 (defmethod ensure-message (trace (message protobuf-message))
 339   (let ((trace (cons message trace)))
 340     (map () (curry #'ensure-message trace) (proto-messages message))
 341     (map () (curry #'ensure-field trace message) (proto-fields message))))
 342
 343 (defmethod ensure-field (trace message (field protobuf-field))
 344   (ensure-type trace message field (proto-class field)))
 345
 346 (defmethod ensure-service (trace (service protobuf-service))
 347   (map () (curry #'ensure-rpc trace service) (proto-rpcs service)))
 348
 349 (defmethod ensure-rpc (trace service (rpc protobuf-rpc))
 350   (ensure-type trace service rpc (proto-input-type rpc))
 351   (ensure-type trace service rpc (proto-output-type rpc)))
 352
 353 ;; 'message' and 'field' can be a message and a field or a service and an RPC
 354 (defun ensure-type (trace message field type)
 355   (unless (keywordp type)
 356     (let ((msg (loop for p in trace
 357                      thereis (or (find-message p type)
 358                                  (find-enum p type)))))
 359       (unless msg
 360         (push (cons message field) (gethash type *undefined-messages*))))))