;;; ;;;
;;; 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 ;;;
;;; ;;;
options)
:documentation documentation))
(*protobuf* schema)
- (*protobuf-package* (or (find-proto-package lisp-pkg) *package*)))
- (apply #'process-imports schema imports)
+ (*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),
(ecase model-type
((define-enum)
(setf (proto-enums schema) (nconc (proto-enums schema) (list model))))
+ ((define-type-alias)
+ (setf (proto-type-aliases schema) (nconc (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)))
',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.
(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)))))
(if alias-for
`(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.
(message (make-instance 'protobuf-message
:class type
:name name
+ :qualified-name (make-qualified-name *protobuf* name)
:parent *protobuf*
: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) ()
(ecase model-type
((define-enum)
(setf (proto-enums message) (nconc (proto-enums message) (list model))))
+ ((define-type-alias)
+ (setf (proto-type-aliases message) (nconc (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)))
;; 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)
+ (collect-type-form `(defclass ,type () (,@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)
collect (make-instance 'protobuf-option
:name (if (symbolp key) (slot-name->proto key) key)
:value val)))
- (message (find-message *protobuf* name))
+ (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)))
(extends (and message
(make-instance 'protobuf-message
- :class type
- :name name
- :parent (proto-parent message)
+ :class (proto-class message)
+ :name (proto-name message)
+ :qualified-name (proto-qualified-name message)
+ :parent *protobuf*
:alias-for alias-for
:conc-name conc-name
:enums (copy-list (proto-enums message))
:messages (copy-list (proto-messages message))
:fields (copy-list (proto-fields message))
+ :extensions (copy-list (proto-extensions message))
:options (remove-options
(or options (copy-list (proto-options message))) "default" "packed")
- :extensions (copy-list (proto-extensions message))
: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))
(assert message ()
(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)
,@(and writer `((defmethod ,writer ((object ,type) value)
(declare (type ,stype value))
(setf (gethash object ,stable) value))))
- ,@(and writer `((defsetf ,reader ,writer)))
;; For Python compatibility
(defmethod get-extension ((object ,type) (slot (eql ',sname)))
(values (gethash object ,stable ,default)))
(declare (ignore value))
foundp))
(defmethod clear-extension ((object ,type) (slot (eql ',sname)))
- (remhash object ,stable)))))))
+ (remhash object ,stable)))
+ ,@(and writer
+ ;; '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)))))))
,@(and writer `((defmethod ,writer ((object ,type) value)
(declare (type ,stype value))
(setf (gethash object ,stable) value))))
- ,@(and writer `((defsetf ,reader ,writer)))
- ;; For Python compatibility
(defmethod get-extension ((object ,type) (slot (eql ',sname)))
(values (gethash object ,stable ,default)))
(defmethod set-extension ((object ,type) (slot (eql ',sname)) value)
(declare (ignore value))
foundp))
(defmethod clear-extension ((object ,type) (slot (eql ',sname)))
- (remhash object ,stable)))))
+ (remhash object ,stable)))
+ ,@(and writer
+ `((eval-when (:compile-toplevel :load-toplevel :execute)
+ (defsetf ,reader ,writer))))))
;; This so that (de)serialization works
(setf (proto-reader field) reader
(proto-writer field) writer)))
(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
:name (slot-name->proto slot)
:type name
:class type
+ :qualified-name (make-qualified-name *protobuf* (slot-name->proto slot))
+ :parent *protobuf*
:required arity
:index index
:value slot
(message (make-instance 'protobuf-message
:class type
:name name
+ :qualified-name (make-qualified-name *protobuf* name)
+ :parent *protobuf*
:alias-for alias-for
: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) ()
(ecase model-type
((define-enum)
(setf (proto-enums message) (nconc (proto-enums message) (list model))))
+ ((define-type-alias)
+ (setf (proto-type-aliases message) (nconc (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)))
;; 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)
+ (collect-type-form `(defclass ,type () (,@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))))
(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
:name (or name (slot-name->proto slot))
: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
:documentation documentation)))
(values field cslot idx)))))))
+(defparameter *rpc-package* nil
+ "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.
+ 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
(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))
+ (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)))
+ :documentation documentation
+ :source-location source-location)))
(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))
+ ;; 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))))
+ #-sbcl (declare (values ,output-type))
+ (:method (,vchannel (,vrequest ,input-type) &key ,vcallback)
+ (declare (ignorable ,vchannel ,vcallback))
+ (let ((call (and *rpc-package* *rpc-call-function*)))
+ (assert call ()
+ "There is no RPC package loaded!")
+ (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)))))))
\f
;;; Ensure everything in a Protobufs schema is defined
(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)
projects / cl-protobufs.git / blobdiff