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