X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=define-proto.lisp;h=9f6cca4055839cab758df66ff4c1c154c82d1648;hb=ae85cfed94d4b1d69529ceaac32a7583198ff485;hp=52215ad1b3a27772a21c6cd761aa3d7e7bb79154;hpb=410b3edcfc0603e1adc05ef45e92635fb9f853a4;p=cl-protobufs.git diff --git a/define-proto.lisp b/define-proto.lisp index 52215ad..9f6cca4 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -2,7 +2,7 @@ ;;; ;;; ;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; -;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; +;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Scott McKay ;;; ;;; ;;; @@ -13,6 +13,18 @@ ;;; Protocol buffer defining macros +;;; Base class for all Protobufs-defined classes + +(defclass base-protobuf-message () + ;; Just one slot, to hold a size cached by 'object-size' + ((%cached-size :type (or null fixnum) + :initform nil)) + (:documentation + "The base class for all user-defined Protobufs messages.")) + + +;;; The macros + ;; Define a schema named 'type', corresponding to a .proto file of that name (defmacro define-schema (type (&key name syntax package lisp-package import optimize options documentation) @@ -33,9 +45,7 @@ (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package)))) (options (remove-options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val)) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val)) "optimize_for" "lisp_package")) (imports (if (listp import) import (list import))) (schema (make-instance 'protobuf-schema @@ -46,21 +56,22 @@ :lisp-package (or lisp-pkg (substitute #\- #\_ package)) :imports imports :options (if optimize - (append options (list (make-instance 'protobuf-option - :name "optimize_for" - :value (if (eq optimize :speed) "SPEED" "CODE_SIZE") - :type 'symbol))) + (append options + (list (make-option "optimize_for" (if (eq optimize :speed) "SPEED" "CODE_SIZE") 'symbol))) options) :documentation documentation)) (*protobuf* schema) - (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))) + (*protobuf-package* (or (find-proto-package lisp-pkg) *package*)) + (*protobuf-rpc-package* (or (find-proto-package (format nil "~A-~A" lisp-pkg 'rpc)) *package*))) (process-imports schema imports) (with-collectors ((forms collect-form)) (dolist (msg messages) (assert (and (listp msg) - (member (car msg) '(define-enum define-message define-extend define-service))) () + (member (car msg) '(define-enum define-message define-extend define-service + define-type-alias))) () "The body of ~S must be one of ~{~S~^ or ~}" - 'define-schema '(define-enum define-message define-extend define-service)) + 'define-schema + '(define-enum define-message define-extend define-service define-type-alias)) ;; The macro-expander will return a form that consists ;; of 'progn' followed by a symbol naming what we've expanded ;; (define-enum, define-message, define-extend, define-service), @@ -73,14 +84,16 @@ (map () #'collect-form definers) (ecase model-type ((define-enum) - (setf (proto-enums schema) (nconc (proto-enums schema) (list model)))) + (appendf (proto-enums schema) (list model))) + ((define-type-alias) + (appendf (proto-type-aliases schema) (list model))) ((define-message define-extend) (setf (proto-parent model) schema) - (setf (proto-messages schema) (nconc (proto-messages schema) (list model))) + (appendf (proto-messages schema) (list model)) (when (eq (proto-message-type model) :extends) - (setf (proto-extenders schema) (nconc (proto-extenders schema) (list model))))) + (appendf (proto-extenders schema) (list model)))) ((define-service) - (setf (proto-services schema) (nconc (proto-services schema) (list model))))))) + (appendf (proto-services schema) (list model)))))) (let ((var (intern (format nil "*~A*" type) *protobuf-package*))) `(progn ,@forms @@ -95,22 +108,54 @@ ',type ',name) (map () #'protobufs-warn warnings)))) (setq ,var new-schema) - (record-protobuf ,var) - ,@(with-collectors ((messages collect-message)) - (labels ((collect-messages (message) - (collect-message message) - (map () #'collect-messages (proto-messages message)))) - (map () #'collect-messages (proto-messages schema))) - (append - (mapcar #'(lambda (m) `(record-protobuf ,m)) messages) - (when (eq optimize :speed) - (append (mapcar #'generate-object-size messages) - (mapcar #'generate-serializer messages) - (mapcar #'generate-deserializer messages))))) - ,var)))))) + (record-protobuf ,var)) + ,@(with-collectors ((messages collect-message)) + (labels ((collect-messages (message) + (collect-message message) + (map () #'collect-messages (proto-messages message)))) + (map () #'collect-messages (proto-messages schema))) + (append + (mapcar #'(lambda (m) `(record-protobuf ,m)) messages) + (when (eq optimize :speed) + (append (mapcar #'generate-object-size messages) + (mapcar #'generate-serializer messages) + (mapcar #'generate-deserializer messages))))) + ,var))))) + +(defmacro with-proto-source-location ((type name definition-type + &optional pathname start-pos end-pos) + &body body) + "Establish a context which causes the generated Lisp code to have + source location information that points to the .proto file. + 'type' is the name of the Lisp definition (a symbol). + 'name' is the name of the Protobufs definition (a string). + 'definition-type' is the kind of definition, e.g., 'protobuf-enum'. + 'pathname', 'start-pos' and 'end-pos' give the location of the definition + in the .proto file." + `(progn + (record-proto-source-location ',type ,name ',definition-type + ,pathname ,start-pos ,end-pos) + ,@body)) + +#+ccl +(defun record-proto-source-location (type name definition-type + &optional pathname start-pos end-pos) + (declare (ignore name)) + (when (and ccl::*record-source-file* + (typep pathname '(or string pathname))) + (let ((ccl::*loading-toplevel-location* (ccl::make-source-note :filename pathname + :start-pos start-pos + :end-pos end-pos))) + (ccl:record-source-file type definition-type)))) + +#-(or ccl) +(defun record-proto-source-location (type name definition-type + &optional pathname start-pos end-pos) + (declare (ignorable name type definition-type pathname start-pos end-pos))) ;; Define an enum type named 'type' and a Lisp 'deftype' -(defmacro define-enum (type (&key name conc-name alias-for options documentation) +(defmacro define-enum (type (&key name conc-name alias-for options + documentation source-location) &body values) "Define a Protobufs enum type and a Lisp 'deftype' named 'type'. 'name' can be used to override the defaultly generated Protobufs enum name. @@ -122,31 +167,37 @@ The body consists of the enum values in the form 'name' or (name index)." (let* ((name (or name (class-name->proto type))) (options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val))) (conc-name (conc-name-for-type type conc-name)) (index -1) (enum (make-instance 'protobuf-enum :class type :name name :qualified-name (make-qualified-name *protobuf* name) + :parent *protobuf* :alias-for alias-for :options options - :documentation documentation))) + :documentation documentation + :source-location source-location))) (with-collectors ((vals collect-val) (forms collect-form)) (dolist (val values) - (let* ((idx (if (listp val) (second val) (incf index))) + ;; Allow old (name index) and new (name :index index) + (let* ((idx (if (listp val) + (if (eq (second val) :index) (third val) (second val)) + (incf index))) (name (if (listp val) (first val) val)) (val-name (kintern (if conc-name (format nil "~A~A" conc-name name) (symbol-name name)))) (enum-name (if conc-name (format nil "~A~A" conc-name name) (symbol-name name))) + (vname (enum-name->proto enum-name)) (enum-val (make-instance 'protobuf-enum-value - :name (enum-name->proto enum-name) - :index idx - :value val-name))) + :name vname + :qualified-name (make-qualified-name enum vname) + :index idx + :value val-name + :parent enum))) (collect-val val-name) - (setf (proto-values enum) (nconc (proto-values enum) (list enum-val))))) + (appendf (proto-values enum) (list enum-val)))) (if alias-for ;; If we've got an alias, define a a type that is the subtype of ;; the Lisp enum so that typep and subtypep work @@ -157,10 +208,12 @@ `(progn define-enum ,enum - ,forms)))) + ((with-proto-source-location (,type ,name protobuf-enum ,@source-location) + ,@forms)))))) ;; Define a message named 'name' and a Lisp 'defclass' -(defmacro define-message (type (&key name conc-name alias-for options documentation) +(defmacro define-message (type (&key name conc-name alias-for options + documentation source-location) &body fields &environment env) "Define a message named 'type' and a Lisp 'defclass'. 'name' can be used to override the defaultly generated Protobufs message name. @@ -184,9 +237,7 @@ 'writer' is a Lisp slot writer function to use to set the value." (let* ((name (or name (class-name->proto type))) (options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val))) (conc-name (conc-name-for-type type conc-name)) (message (make-instance 'protobuf-message :class type @@ -196,15 +247,20 @@ :alias-for alias-for :conc-name conc-name :options (remove-options options "default" "packed") - :documentation documentation)) + :documentation documentation + :source-location source-location)) (index 0) ;; Only now can we bind *protobuf* to the new message (*protobuf* message)) (with-collectors ((slots collect-slot) - (forms collect-form)) + (forms collect-form) + ;; The typedef needs to be first in forms otherwise ccl warns. + ;; We'll collect them separately and splice them in first. + (type-forms collect-type-form)) (dolist (field fields) (case (car field) - ((define-enum define-message define-extend define-extension define-group) + ((define-enum define-message define-extend define-extension define-group + define-type-alias) (destructuring-bind (&optional progn model-type model definers extra-field extra-slot) (macroexpand-1 field env) (assert (eq progn 'progn) () @@ -212,20 +268,22 @@ (map () #'collect-form definers) (ecase model-type ((define-enum) - (setf (proto-enums message) (nconc (proto-enums message) (list model)))) + (appendf (proto-enums message) (list model))) + ((define-type-alias) + (appendf (proto-type-aliases message) (list model))) ((define-message define-extend) (setf (proto-parent model) message) - (setf (proto-messages message) (nconc (proto-messages message) (list model))) + (appendf (proto-messages message) (list model)) (when (eq (proto-message-type model) :extends) - (setf (proto-extenders message) (nconc (proto-extenders message) (list model))))) + (appendf (proto-extenders message) (list model)))) ((define-group) (setf (proto-parent model) message) - (setf (proto-messages message) (nconc (proto-messages message) (list model))) + (appendf (proto-messages message) (list model)) (when extra-slot (collect-slot extra-slot)) - (setf (proto-fields message) (nconc (proto-fields message) (list extra-field)))) + (appendf (proto-fields message) (list extra-field))) ((define-extension) - (setf (proto-extensions message) (nconc (proto-extensions message) (list model))))))) + (appendf (proto-extensions message) (list model)))))) (otherwise (multiple-value-bind (field slot idx) (process-field field index :conc-name conc-name :alias-for alias-for) @@ -235,25 +293,27 @@ (setq index idx) (when slot (collect-slot slot)) - (setf (proto-fields message) (nconc (proto-fields message) (list field))))))) + (appendf (proto-fields message) (list field)))))) (if alias-for ;; If we've got an alias, define a a type that is the subtype of ;; the Lisp class that typep and subtypep work (unless (or (eq type alias-for) (find-class type nil)) - (collect-form `(deftype ,type () ',alias-for))) + (collect-type-form `(deftype ,type () ',alias-for))) ;; If no alias, define the class now - (collect-form `(defclass ,type () (,@slots) - ,@(and documentation `((:documentation ,documentation)))))) + (collect-type-form `(defclass ,type (#+use-base-protobuf-message base-protobuf-message) (,@slots) + ,@(and documentation `((:documentation ,documentation)))))) `(progn define-message ,message - ,forms)))) + ((with-proto-source-location (,type ,name protobuf-message ,@source-location) + ,@type-forms + ,@forms)))))) (defun conc-name-for-type (type conc-name) (and conc-name (typecase conc-name - ((member t) (format nil "~A-" type)) - ((or string symbol) (string conc-name)) + ((member t) (format nil "~:@(~A~)-" type)) + ((or string symbol) (string-upcase (string conc-name))) (t nil)))) (defmacro define-extension (from to) @@ -287,10 +347,8 @@ 'writer' is a Lisp slot writer function to use to set the value." (let* ((name (or name (class-name->proto type))) (options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))) - (message (find-message *protobuf* name)) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val))) + (message (find-message *protobuf* type)) (conc-name (or (conc-name-for-type type conc-name) (and message (proto-conc-name message)))) (alias-for (and message (proto-alias-for message))) @@ -299,7 +357,7 @@ :class (proto-class message) :name (proto-name message) :qualified-name (proto-qualified-name message) - :parent (proto-parent message) + :parent *protobuf* :alias-for alias-for :conc-name conc-name :enums (copy-list (proto-enums message)) @@ -309,7 +367,8 @@ :options (remove-options (or options (copy-list (proto-options message))) "default" "packed") :message-type :extends ;this message is an extension - :documentation documentation))) + :documentation documentation + :type-aliases (copy-list (proto-type-aliases message))))) ;; Only now can we bind *protobuf* to the new extended message (*protobuf* extends) (index 0)) @@ -321,7 +380,8 @@ (with-collectors ((forms collect-form)) (dolist (field fields) (assert (not (member (car field) - '(define-enum define-message define-extend define-extension))) () + '(define-enum define-message define-extend define-extension + define-type-alias))) () "The body of ~S can only contain field and group definitions" 'define-extend) (case (car field) ((define-group) @@ -333,7 +393,7 @@ (ecase model-type ((define-group) (setf (proto-parent model) extends) - (setf (proto-messages extends) (nconc (proto-messages extends) (list model))) + (appendf (proto-messages extends) (list model)) (when extra-slot ;;--- Refactor to get rid of all this duplicated code! (let* ((inits (cdr extra-slot)) @@ -371,9 +431,9 @@ ;; 'defsetf' needs to be visible at compile time `((eval-when (:compile-toplevel :load-toplevel :execute) (defsetf ,reader ,writer)))))))) - (setf (proto-message-type extra-field) :extends) ;this field is an extension - (setf (proto-fields extends) (nconc (proto-fields extends) (list extra-field))) - (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list extra-field))))))) + (setf (proto-message-type extra-field) :extends) ;this field is an extension + (appendf (proto-fields extends) (list extra-field)) + (appendf (proto-extended-fields extends) (list extra-field)))))) (otherwise (multiple-value-bind (field slot idx) (process-field field index :conc-name conc-name :alias-for alias-for) @@ -428,8 +488,8 @@ (setf (proto-reader field) reader (proto-writer field) writer))) (setf (proto-message-type field) :extends) ;this field is an extension - (setf (proto-fields extends) (nconc (proto-fields extends) (list field))) - (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field))))))) + (appendf (proto-fields extends) (list field)) + (appendf (proto-extended-fields extends) (list field)))))) `(progn define-extend ,extends @@ -442,7 +502,8 @@ (i<= index (proto-extension-to ext)))) extensions))) -(defmacro define-group (type (&key index arity name conc-name alias-for reader options documentation) +(defmacro define-group (type (&key index arity name conc-name alias-for reader options + documentation source-location) &body fields &environment env) "Define a message named 'type' and a Lisp 'defclass', *and* a field named type. This is deprecated in Protobufs, but if you have to use it, you must give @@ -471,9 +532,7 @@ (let* ((slot (or type (and name (proto->slot-name name *protobuf-package*)))) (name (or name (class-name->proto type))) (options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val))) (conc-name (conc-name-for-type type conc-name)) (reader (or reader (let ((msg-conc (proto-conc-name *protobuf*))) @@ -497,6 +556,7 @@ :type name :class type :qualified-name (make-qualified-name *protobuf* (slot-name->proto slot)) + :parent *protobuf* :required arity :index index :value slot @@ -511,15 +571,20 @@ :conc-name conc-name :options (remove-options options "default" "packed") :message-type :group ;this message is a group - :documentation documentation)) + :documentation documentation + :source-location source-location)) (index 0) ;; Only now can we bind *protobuf* to the (group) message (*protobuf* message)) (with-collectors ((slots collect-slot) - (forms collect-form)) + (forms collect-form) + ;; The typedef needs to be first in forms otherwise ccl warns. + ;; We'll collect them separately and splice them in first. + (type-forms collect-type-form)) (dolist (field fields) (case (car field) - ((define-enum define-message define-extend define-extension define-group) + ((define-enum define-message define-extend define-extension define-group + define-type-alias) (destructuring-bind (&optional progn model-type model definers extra-field extra-slot) (macroexpand-1 field env) (assert (eq progn 'progn) () @@ -527,20 +592,22 @@ (map () #'collect-form definers) (ecase model-type ((define-enum) - (setf (proto-enums message) (nconc (proto-enums message) (list model)))) + (appendf (proto-enums message) (list model))) + ((define-type-alias) + (appendf (proto-type-aliases message) (list model))) ((define-message define-extend) (setf (proto-parent model) message) - (setf (proto-messages message) (nconc (proto-messages message) (list model))) + (appendf (proto-messages message) (list model)) (when (eq (proto-message-type model) :extends) - (setf (proto-extenders message) (nconc (proto-extenders message) (list model))))) + (appendf (proto-extenders message) (list model)))) ((define-group) (setf (proto-parent model) message) - (setf (proto-messages message) (nconc (proto-messages message) (list model))) + (appendf (proto-messages message) (list model)) (when extra-slot (collect-slot extra-slot)) - (setf (proto-fields message) (nconc (proto-fields message) (list extra-field)))) + (appendf (proto-fields message) (list extra-field))) ((define-extension) - (setf (proto-extensions message) (nconc (proto-extensions message) (list model))))))) + (appendf (proto-extensions message) (list model)))))) (otherwise (multiple-value-bind (field slot idx) (process-field field index :conc-name conc-name :alias-for alias-for) @@ -550,19 +617,21 @@ (setq index idx) (when slot (collect-slot slot)) - (setf (proto-fields message) (nconc (proto-fields message) (list field))))))) + (appendf (proto-fields message) (list field)))))) (if alias-for ;; If we've got an alias, define a a type that is the subtype of ;; the Lisp class that typep and subtypep work (unless (or (eq type alias-for) (find-class type nil)) - (collect-form `(deftype ,type () ',alias-for))) + (collect-type-form `(deftype ,type () ',alias-for))) ;; If no alias, define the class now - (collect-form `(defclass ,type () (,@slots) - ,@(and documentation `((:documentation ,documentation)))))) + (collect-type-form `(defclass ,type (#+use-base-protobuf-message base-protobuf-message) (,@slots) + ,@(and documentation `((:documentation ,documentation)))))) `(progn define-group ,message - ,forms + ((with-proto-source-location (,type ,name protobuf-message ,@source-location) + ,@type-forms + ,@forms)) ,mfield ,mslot)))) @@ -573,8 +642,12 @@ (setq index 19999)) (destructuring-bind (slot &rest other-options &key type reader writer name (default nil default-p) packed - options documentation &allow-other-keys) field - (let* ((idx (if (listp slot) (second slot) (iincf index))) + ((:index idx)) options documentation &allow-other-keys) field + ;; Allow old ((slot index) ...) or new (slot :index ...), + ;; but only allow one of those two to be used simultaneously + (assert (if idx (not (listp slot)) t) () + "Use either ((slot index) ...) or (slot :index index ...), but not both") + (let* ((idx (or idx (if (listp slot) (second slot) (iincf index)))) (slot (if (listp slot) (first slot) slot)) (reader (or reader (and conc-name @@ -582,13 +655,9 @@ (options (append (loop for (key val) on other-options by #'cddr unless (member key '(:type :reader :writer :name :default :packed :documentation)) - collect (make-instance 'protobuf-option - :name (slot-name->proto key) - :value val)) + collect (make-option (slot-name->proto key) val)) (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))))) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val))))) (multiple-value-bind (ptype pclass) (clos-type-to-protobuf-type type) (multiple-value-bind (reqd vectorp) @@ -622,6 +691,7 @@ :type ptype :class pclass :qualified-name (make-qualified-name *protobuf* (or name (slot-name->proto slot))) + :parent *protobuf* ;; One of :required, :optional or :repeated :required reqd :index idx @@ -636,111 +706,171 @@ (values field cslot idx))))))) (defparameter *rpc-package* nil - "The Lisp package that implements RPC.") + "The Lisp package that implements RPC. + This should be set when an RPC package that uses CL-Protobufs gets loaded.") (defparameter *rpc-call-function* nil - "The Lisp function that implements RPC client-side calls.") + "The Lisp function that implements RPC client-side calls. + This should be set when an RPC package that uses CL-Protobufs gets loaded.") ;; Define a service named 'type' with generic functions declared for ;; each of the methods within the service -(defmacro define-service (type (&key name options documentation) +(defmacro define-service (type (&key name options + documentation source-location) &body method-specs) "Define a service named 'type' and Lisp 'defgeneric' for all its methods. 'name' can be used to override the defaultly generated Protobufs service name. 'options' is a set of keyword/value pairs, both of which are strings. - The body is a set of method specs of the form (name (input-type output-type) &key options). + The body is a set of method specs of the form (name (input-type [=>] output-type) &key options). 'input-type' and 'output-type' may also be of the form (type &key name)." (let* ((name (or name (class-name->proto type))) (options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val))) (service (make-instance 'protobuf-service :class type :name name :qualified-name (make-qualified-name *protobuf* name) + :parent *protobuf* :options options - :documentation documentation)) + :documentation documentation + :source-location source-location)) (index 0)) (with-collectors ((forms collect-form)) (dolist (method method-specs) - (destructuring-bind (function (input-type output-type) &key name options documentation) method - (let* ((input-name (and (listp input-type) + (destructuring-bind (function (&rest types) + &key name options documentation source-location) method + (let* ((input-type (first types)) + (output-type (if (string= (string (second types)) "=>") (third types) (second types))) + (streams-type (if (string= (string (second types)) "=>") + (getf (cdddr types) :streams) + (getf (cddr types) :streams))) + (input-name (and (listp input-type) (getf (cdr input-type) :name))) (input-type (if (listp input-type) (car input-type) input-type)) (output-name (and (listp output-type) (getf (cdr output-type) :name))) (output-type (if (listp output-type) (car output-type) output-type)) + (streams-name (and (listp streams-type) + (getf (cdr streams-type) :name))) + (streams-type (if (listp streams-type) (car streams-type) streams-type)) (options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))) - (package *protobuf-package*) - (client-fn function) - (server-fn (intern (format nil "~A-~A" 'do function) package)) + collect (make-option (if (symbolp key) (slot-name->proto key) key) val))) + (package *protobuf-rpc-package*) + (client-fn (intern (format nil "~A-~A" 'call function) package)) + (server-fn (intern (format nil "~A-~A" function 'impl) package)) (method (make-instance 'protobuf-method :class function :name (or name (class-name->proto function)) :qualified-name (make-qualified-name *protobuf* (or name (class-name->proto function))) + :parent service :client-stub client-fn :server-stub server-fn :input-type input-type :input-name (or input-name (class-name->proto input-type)) :output-type output-type :output-name (or output-name (class-name->proto output-type)) + :streams-type streams-type + :streams-name (and streams-type + (or streams-name (class-name->proto streams-type))) :index (iincf index) :options options - :documentation documentation))) - (setf (proto-methods service) (nconc (proto-methods service) (list method))) - ;; The following are the hooks to CL-Stubby - (let* ((vinput (intern (format nil "~A-~A" (symbol-name input-type) 'in) package)) - (voutput (intern (format nil "~A-~A" (symbol-name output-type) 'out) package)) + :documentation documentation + :source-location source-location))) + (appendf (proto-methods service) (list method)) + ;; The following are the hooks to an RPC implementation + (let* ((vrequest (intern (symbol-name 'request) package)) (vchannel (intern (symbol-name 'channel) package)) (vcallback (intern (symbol-name 'callback) package))) ;; The client side stub, e.g., 'read-air-reservation'. - ;; The expectation is that CL-Stubby will provide macrology to make it + ;; The expectation is that the RPC implementation will provide code to make it ;; easy to implement a method for this on each kind of channel (HTTP, TCP socket, ;; IPC, etc). Unlike C++/Java/Python, we don't need a client-side subclass, ;; because we can just use multi-methods. - ;; The CL-Stubby macros take care of serializing the input, transmitting the + ;; The 'do-XXX' method calls the RPC code with the channel, the method + ;; (i.e., a 'protobuf-method' object), the request and the callback function. + ;; The RPC code should take care of serializing the input, transmitting the ;; request over the wire, waiting for input (or not if it's asynchronous), - ;; filling in the output, and calling the callback (if it's asynchronous). - ;; It's not very Lispy to side-effect an output object, but it makes - ;; asynchronous calls simpler. - (collect-form `(defgeneric ,client-fn (,vchannel ,vinput ,voutput &key ,vcallback) + ;; filling in the output, and either returning the response (if synchronous) + ;; or calling the callback with the response as an argument (if asynchronous). + ;; It will also deserialize the response so that the client code sees the + ;; response as an application object. + (collect-form `(defgeneric ,client-fn (,vchannel ,vrequest &key ,vcallback) ,@(and documentation `((:documentation ,documentation))) #-sbcl (declare (values ,output-type)) - (:method (,vchannel (,vinput ,input-type) (,voutput ,output-type) &key ,vcallback) + (:method (,vchannel (,vrequest ,input-type) &key ,vcallback) (declare (ignorable ,vchannel ,vcallback)) - (let ((call (and *rpc-package* *rpc-call-function* - (find-symbol *rpc-call-function* *rpc-package*)))) + (let ((call (and *rpc-package* *rpc-call-function*))) (assert call () "There is no RPC package loaded!") - (funcall call ,vchannel ',method ,vinput ,voutput + (funcall call ,vchannel ',method ,vrequest :callback ,vcallback))))) ;; The server side stub, e.g., 'do-read-air-reservation'. ;; The expectation is that the server-side program will implement ;; a method with the business logic for this on each kind of channel ;; (HTTP, TCP socket, IPC, etc), possibly on a server-side subclass - ;; of the input class + ;; of the input class. ;; The business logic is expected to perform the correct operations on ;; the input object, which arrived via Protobufs, and produce an output - ;; of the given type, which will be serialized as a result. + ;; of the given type, which will be serialized and sent back over the wire. ;; The channel objects hold client identity information, deadline info, - ;; etc, and can be side-effected to indicate success or failure - ;; CL-Stubby provides the channel classes and does (de)serialization, etc - (collect-form `(defgeneric ,server-fn (,vchannel ,vinput ,voutput) + ;; etc, and can be side-effected to indicate success or failure. + ;; The RPC code provides the channel classes and does (de)serialization, etc + (collect-form `(defgeneric ,server-fn (,vchannel ,vrequest) ,@(and documentation `((:documentation ,documentation))) #-sbcl (declare (values ,output-type)))))))) `(progn define-service ,service - ,forms)))) + ((with-proto-source-location (,type ,name protobuf-service ,@source-location) + ,@forms)))))) + + +;; Lisp-only type aliases +(defmacro define-type-alias (type (&key name alias-for documentation source-location) + &key lisp-type proto-type serializer deserializer) + "Define a Protobufs type alias Lisp 'deftype' named 'type'. + 'lisp-type' is the name of the Lisp type. + 'proto-type' is the name of a primitive Protobufs type, e.g., 'int32' or 'string'. + 'serializer' is a function that takes a Lisp object and generates a Protobufs object. + 'deserializer' is a function that takes a Protobufs object and generates a Lisp object. + If 'alias-for' is given, no Lisp 'deftype' will be defined." + (multiple-value-bind (type-str proto) + (lisp-type-to-protobuf-type proto-type) + (assert (keywordp proto) () + "The alias ~S must resolve to a Protobufs primitive type" + type) + (let* ((name (or name (class-name->proto type))) + (alias (make-instance 'protobuf-type-alias + :class type + :name name + :lisp-type lisp-type + :proto-type proto + :proto-type-str type-str + :serializer serializer + :deserializer deserializer + :qualified-name (make-qualified-name *protobuf* name) + :parent *protobuf* + :documentation documentation + :source-location source-location))) + (with-collectors ((forms collect-form)) + (if alias-for + ;; If we've got an alias, define a a type that is the subtype of + ;; the Lisp enum so that typep and subtypep work + (unless (eq type alias-for) + (collect-form `(deftype ,type () ',alias-for))) + ;; If no alias, define the Lisp enum type now + (collect-form `(deftype ,type () ',lisp-type))) + `(progn + define-type-alias + ,alias + ((with-proto-source-location (,type ,name protobuf-type-alias ,@source-location) + ,@forms))))))) ;;; Ensure everything in a Protobufs schema is defined -(defvar *undefined-messages*) +(defvar *undefined-messages* nil + "Bound to a list of undefined messages during schame validation.") ;; A very useful tool during development... (defun ensure-all-schemas () @@ -787,7 +917,8 @@ (defgeneric ensure-method (trace service method) (:method (trace service (method protobuf-method)) (ensure-type trace service method (proto-input-type method)) - (ensure-type trace service method (proto-output-type method)))) + (ensure-type trace service method (proto-output-type method)) + (ensure-type trace service method (proto-streams-type method)))) ;; 'message' and 'field' can be a message and a field or a service and a method (defun ensure-type (trace message field type)