If the file is a .proto file, it first parses it and writes a .lisp file.
The .lisp file is the compiled and loaded."
(dolist (import imports)
- (let* ((base-path (if *compile-file-pathname*
- (merge-pathnames (pathname import) *compile-file-pathname*)
- (pathname import)))
+ (let* ((import-dir (pathname-directory (pathname import)))
+ (import-name (pathname-name (pathname import)))
+ (imported (find-schema (class-name->proto import-name)))
+ ;;---*** This just isn't right, either in QRes or Google3
+ (base-dir (ecase (car import-dir)
+ (:relative
+ (assert *compile-file-pathname* ()
+ "You need a compile-file pathname for relative imports")
+ import-dir)
+ (:absolute
+ import-dir)))
+ (base-path (make-pathname :name import-name :directory base-dir
+ :defaults *compile-file-pathname*))
(proto-file (make-pathname :type "proto" :defaults base-path))
(lisp-file (make-pathname :type "lisp" :defaults base-path))
(fasl-file (compile-file-pathname lisp-file))
(ignore-errors (file-write-date lisp-file))))
(fasl-date (and (probe-file fasl-file)
(ignore-errors (file-write-date fasl-file)))))
+ (when imported
+ (setf (proto-imported-schemas schema)
+ (nconc (proto-imported-schemas schema) (list imported)))
+ (return-from process-imports imported))
(when (string= (pathname-type base-path) "proto")
;; The user asked to import a .proto file
;; If there's no .lisp file or an older .lisp file, parse the .proto file now
(let* ((imported (find-schema base-path)))
(when imported
(setf (proto-imported-schemas schema)
- (nconc (proto-imported-schemas schema) (list imported)))))
- base-path)))
+ (nconc (proto-imported-schemas schema) (list imported))))
+ imported))))
2.3 Using .proto files directly
2.4 Using the Protobufs macros
2.4.1 Protobufs types
+ 2.4.2 Protobufs service stubs
3 Serializing and deserializing
3.1 Wire format
3.2 Text format
Note that ``(or <T> null)`` corresponds to an optional field.
+Protobufs service stubs
+-----------------------
+
+When you use the ``proto:define-service`` macro to define a service
+with some methods, the macro defines "stubs" (CLOS generic functions)
+for each of the methods in the service. Each method gets a client stub
+and a server stub whose signatures are, respectively::
+
+ (rpc-channel input output &key callback) => output
+ (rpc-channel input output) => output
+
+The type of *rpc-channel* is unspecified, but is meant to be a
+"channel" over which some sort of RPC call will be done. The types of
+*input* and *output* are classes that were defined via
+Protobufs. *callback* is a function of two arguments, the RPC channel
+and the output; it is intended for use by asynchronous RPC calls.
+
+For example, this fragment defines four stubs::
+
+ (proto:define-service color-wheel ()
+ (get-color (get-color-request color))
+ (add-color (add-color-request color)))
+
+The client stubs are ``get-color`` and ``add-color``, the server stubs
+are ``do-get-color`` and ``do-add-color``. An RPC library will implement
+a method for the client stub. You must fill in the server stub yourself;
+it will implement the desired functionality.
+
+It is beyond the scope of this Protobufs library to provide the RPC
+service; that is the domain of another library.
+
+
Serializing and deserializing
=============================
options)
:documentation documentation))
(*protobuf* schema)
- (*protobuf-package* (or (find-package lisp-pkg)
- (find-package (string-upcase lisp-pkg))
- *package*)))
+ (*protobuf-package* (or (find-proto-package lisp-pkg) *package*)))
(apply #'process-imports schema imports)
(with-collectors ((forms collect-form))
(dolist (msg messages)
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))
(method (make-instance 'protobuf-method
:class function
:name (or name (class-name->proto function))
+ :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
:documentation documentation)))
(setf (proto-methods service) (nconc (proto-methods service) (list method)))
;; The following are the hooks to CL-Stubby
- (let* ((package *protobuf-package*)
- (client-fn function)
- (server-fn (intern (format nil "~A-~A" 'do function) package))
- (vinput (intern (format nil "~A-~A" (symbol-name input-type) 'in) package))
+ (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))
(vchannel (intern (symbol-name 'channel) package))
(vcallback (intern (symbol-name 'callback) package)))
;; because we can just use multi-methods.
;; The CL-Stubby macros 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 synchronous).
+ ;; 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)
;; 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 &key ,vcallback)
+ (collect-form `(defgeneric ,server-fn (,vchannel ,vinput ,voutput)
,@(and documentation `((:documentation ,documentation)))
#-sbcl (declare (values ,output-type))))))))
`(progn
:reader proto-name
:initarg :name
:initform nil)
+ (full-name :type (or null string) ;the fully qualified name, e.g., "proto2.MessageSet"
+ :accessor proto-qualified-name
+ :initarg :qualified-name
+ :initform nil)
(options :type (list-of protobuf-option) ;options, mostly just passed along
:accessor proto-options
:initarg :options
(:documentation
"The base class for all Protobufs model classes."))
+(defun find-qualified-name (name protos
+ &key (proto-key #'proto-name) (lisp-key #'proto-class))
+ "Find something by its string name.
+ First do a simple name match.
+ Failing that, exhaustively search qualified names."
+ (or (find name protos :key proto-key :test #'string=)
+ ;; Get desperate in the face of incomplete namespace support
+ ;;--- This needs to be more sophisticated than just using Lisp packages
+ (multiple-value-bind (name package path other)
+ (proto->class-name name)
+ (declare (ignore path))
+ (let* ((name (string name))
+ (symbol (or (and package (find-symbol name package))
+ (and other
+ (find-proto-package other)
+ (find-symbol name (find-proto-package other))))))
+ (when symbol
+ (find symbol protos :key lisp-key))))))
+
;; A Protobufs schema, corresponds to one .proto file
(defclass protobuf-schema (base-protobuf)
(defmethod find-enum ((schema protobuf-schema) (name string))
(labels ((find-it (schema)
- (let ((enum (find name (proto-enums schema) :key #'proto-name :test #'string=)))
+ (let ((enum (find-qualified-name name (proto-enums schema))))
(when enum
(return-from find-enum enum))
(map () #'find-it (proto-imported-schemas schema)))))
(defmethod find-message ((schema protobuf-schema) (name string))
(labels ((find-it (schema)
- (let ((message (or (find name (proto-extenders schema) :key #'proto-name :test #'string=)
- (find name (proto-messages schema) :key #'proto-name :test #'string=))))
+ (let ((message (or (find-qualified-name name (proto-extenders schema))
+ (find-qualified-name name (proto-messages schema)))))
(when message
(return-from find-message message))
(map () #'find-it (proto-imported-schemas schema)))))
(find name (proto-services schema) :key #'proto-class))
(defmethod find-service ((schema protobuf-schema) (name string))
- (find name (proto-services schema) :key #'proto-name :test #'string=))
+ (find-qualified-name name (proto-services schema)))
;; We accept and store any option, but only act on a few: default, packed,
(find-message message (class-name type)))
(defmethod find-message ((message protobuf-message) (name string))
- (or (find name (proto-extenders message) :key #'proto-name :test #'string=)
- (find name (proto-messages message) :key #'proto-name :test #'string=)
+ (or (find-qualified-name name (proto-extenders message))
+ (find-qualified-name name (proto-messages message))
(find-message (proto-parent message) name)))
(defmethod find-enum ((message protobuf-message) type)
(find-enum (proto-parent message) type)))
(defmethod find-enum ((message protobuf-message) (name string))
- (or (find name (proto-enums message) :key #'proto-name :test #'string=)
+ (or (find-qualified-name name (proto-enums message))
(find-enum (proto-parent message) name)))
(defgeneric find-field (message name)
(find name (proto-fields message) :key #'proto-value))
(defmethod find-field ((message protobuf-message) (name string))
- (find name (proto-fields message) :key #'proto-name :test #'string=))
+ (find-qualified-name name (proto-fields message) :lisp-key #'proto-value))
(defmethod find-field ((message protobuf-message) (index integer))
(find index (proto-fields message) :key #'proto-index))
(find name (proto-methods service) :key #'proto-class))
(defmethod find-method ((service protobuf-service) (name string))
- (find name (proto-methods service) :key #'proto-name :test #'string=))
+ (find-qualified-name name (proto-methods service)))
(defmethod find-method ((service protobuf-service) (index integer))
(find index (proto-methods service) :key #'proto-index))
;; A Protobufs method within a service
(defclass protobuf-method (base-protobuf)
- ((itype :type (or null symbol) ;the Lisp type name of the input
- :accessor proto-input-type
- :initarg :input-type
- :initform nil)
+ ((client-fn :type symbol ;the Lisp name of the client stb
+ :accessor proto-client-stub
+ :initarg :client-stub)
+ (server-fn :type symbol ;the Lisp name of the server stb
+ :accessor proto-server-stub
+ :initarg :server-stub)
+ (itype :type symbol ;the Lisp type name of the input
+ :accessor proto-input-type
+ :initarg :input-type)
(iname :type (or null string) ;the Protobufs name of the input
:accessor proto-input-name
:initarg :input-name
:initform nil)
- (otype :type (or null symbol) ;the Lisp type name of the output
- :accessor proto-output-type
- :initarg :output-type
- :initform nil)
+ (otype :type symbol ;the Lisp type name of the output
+ :accessor proto-output-type
+ :initarg :output-type)
(oname :type (or null string) ;the Protobufs name of the output
:accessor proto-output-name
:initarg :output-name
(defmethod print-object ((m protobuf-method) stream)
(print-unreadable-object (m stream :type t :identity t)
(format stream "~S (~S) => (~S)"
- (proto-function m) (proto-input-type m) (proto-output-type m))))
-
-;; The 'class' slot really holds the name of the function,
-;; so let's give it a better name
-(defmethod proto-function ((method protobuf-method))
- (proto-class method))
-
-(defmethod (setf proto-function) (function (method protobuf-method))
- (setf (proto-function method) function))
+ (proto-class m) (proto-input-type m) (proto-output-type m))))
(name (and option (proto-name option)))
(value (and option (proto-value option))))
(when (and option (option-name= name "lisp_package"))
- (let ((package (or (find-package value)
- (find-package (string-upcase value))
- *protobuf-package*)))
+ (let ((package (or (find-proto-package value) *protobuf-package*)))
(setf (proto-lisp-package schema) value)
(setq *protobuf-package* package)))))
((string= token "enum")
(setf (proto-package schema) package)
(unless (proto-lisp-package schema)
(setf (proto-lisp-package schema) lisp-pkg))
- (let ((package (or (find-package lisp-pkg)
- (find-package (string-upcase lisp-pkg))
- *protobuf-package*)))
+ (let ((package (or (find-proto-package lisp-pkg) *protobuf-package*)))
(setq *protobuf-package* package))))
(defun parse-proto-import (stream schema &optional (terminator #\;))
(expect-char stream #\; () "service"))
(maybe-skip-comments stream)
opts))
+ (stub (proto->class-name name *protobuf-package*))
(method (make-instance 'protobuf-method
- :class (proto->class-name name *protobuf-package*)
+ :class stub
:name name
:input-type (proto->class-name in *protobuf-package*)
:input-name in
:output-name out
:index index
:options opts)))
- (let ((name (find-option method "lisp_name")))
- (when name
- (setf (proto-function method) (make-lisp-symbol name))))
+ (let* ((name (find-option method "lisp_name"))
+ (stub (or (and name (make-lisp-symbol name))
+ stub)))
+ (setf (proto-class method) stub
+ (proto-client-stub method) stub
+ (proto-server-stub method) (intern (format nil "~A-~A" 'do stub) *protobuf-package*)))
(assert (string= ret "returns") ()
"Syntax error in 'message' at position ~D" (file-position stream))
(setf (proto-methods service) (nconc (proto-methods service) (list method)))
"BASE-PROTOBUF"
"PROTO-ALIAS-FOR"
"PROTO-CLASS"
+ "PROTO-CLIENT-STUB"
"PROTO-DEFAULT"
"PROTO-DOCUMENTATION"
"PROTO-ENUMS"
"PROTO-EXTENDERS"
"PROTO-EXTENSIONS"
"PROTO-FIELDS"
- "PROTO-FUNCTION"
"PROTO-IMPORTED-SCHEMAS"
"PROTO-IMPORTS"
"PROTO-INDEX"
"PROTO-PACKAGE"
"PROTO-PACKED"
"PROTO-PARENT"
+ "PROTO-QUALIFIED-NAME"
"PROTO-READER"
"PROTO-REQUIRED"
+ "PROTO-SERVER-STUB"
"PROTO-SERVICES"
"PROTO-SLOT"
"PROTO-SYNTAX"
(lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
(*show-lisp-enum-indexes* show-enum-indexes)
(*show-lisp-field-indexes* show-field-indexes)
- (*protobuf-package* (or (find-package lisp-pkg)
- (find-package (string-upcase lisp-pkg))
- *package*))
+ (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))
(*package* *protobuf-package*))
(when (or lisp-pkg pkg)
(let ((pkg (string-upcase (or lisp-pkg pkg))))
- (format stream "~&(eval-when (:execute :compile-toplevel :load-toplevel) ~
- ~% (unless (find-package \"~A\") ~
- ~% (defpackage ~A (:use :COMMON-LISP :PROTOBUFS)))) ~
- ~%(in-package \"~A\")~%~%"
- pkg pkg pkg)))
+ (format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel) ~
+ ~% (unless (cl:find-package \"~A\") ~
+ ~% (cl:defpackage ~A (:use :COMMON-LISP)))) ~
+ ~%(cl:in-package \"~A\") ~
+ ~%(cl:export~%~{ ~S~^~%~})~%~%"
+ pkg pkg pkg (collect-exports schema))))
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~&(proto:define-schema ~(~A~)" (or class name))
&key (indentation 0) more)
(declare (ignore more))
(with-prefixed-accessors
- (function documentation input-type output-type options) (proto- method)
+ (class documentation input-type output-type options) (proto- method)
(when documentation
(write-schema-documentation type documentation stream :indentation indentation))
(format stream "~&~@[~VT~](~(~S~) (~(~S~) ~(~S~))"
(and (not (zerop indentation)) indentation)
- function input-type output-type)
+ class input-type output-type)
(when options
(format stream "~%~VT:options (~{~@/protobuf-option/~^ ~})"
(+ indentation 2) options))
(format stream ")")))
+
+
+;;; Collect symbols to be exported
+
+(defgeneric collect-exports (schema)
+ (:documentation
+ "Collect all the symbols that should be exported from a Protobufs package"))
+
+(defmethod collect-exports ((schema protobuf-schema))
+ (delete-duplicates
+ (delete-if #'(lambda (s) (string-equal s "NIL"))
+ (append (mapcan #'collect-exports (proto-enums schema))
+ (mapcan #'collect-exports (proto-messages schema))
+ (mapcan #'collect-exports (proto-services schema))))
+ :from-end t))
+
+;; Export just the type name
+(defmethod collect-exports ((enum protobuf-enum))
+ (list (symbol-name (proto-class enum))))
+
+;; Export the class name and all of the accessor names
+(defmethod collect-exports ((message protobuf-message))
+ (append (list (symbol-name (proto-class message)))
+ (mapcan #'collect-exports (proto-fields message))))
+
+;; Export just the slot accessor name
+(defmethod collect-exports ((field protobuf-field))
+ (list (symbol-name (proto-slot field))))
+
+;; Export the names of all the methods
+(defmethod collect-exports ((service protobuf-service))
+ (mapcan #'collect-exports (proto-methods service)))
+
+;; Export just the method name
+(defmethod collect-exports ((method protobuf-method))
+ (list (symbol-name (proto-class method))))
((digit-char-p ch)
(uncamel (rest chars) 'digit
(cons ch result)))
- ((eql ch #\_)
- (uncamel (rest chars) '_
+ ((or (eql ch #\-) (eql ch #\_))
+ (uncamel (rest chars) 'dash
(cons #\- result)))
+ ((eql ch #\.)
+ (uncamel (rest chars) 'dot
+ (cons #\. result)))
(t
(error "Invalid name character: ~A" ch))))))
(concatenate 'string (nreverse (uncamel (concatenate 'list name) nil ())))))
(intern (string-upcase x) (find-package "KEYWORD")))
(t nil)))
+
;;; Collectors, etc
(defmacro with-collectors ((&rest collection-descriptions) &body body)
form))
+;;; Types
+
;; A parameterized list type for repeated fields
;; The elements aren't type-checked
(deftype list-of (type)
(deftype vector-of (type)
(if (eq type 'null)
'null
- '(array *)))
+ '(array * (*)))) ;an 1-dimensional array of any type
;; This corresponds to the :bytes Protobufs type
-(deftype byte-vector () '(array (unsigned-byte 8)))
+(deftype byte-vector () '(array (unsigned-byte 8) (*)))
(defun make-byte-vector (size)
(make-array size :element-type '(unsigned-byte 8)))
(defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
(defvar *camel-case-field-names* nil)
+(defun find-proto-package (name)
+ "A very fuzzy definition of 'find-package'."
+ (typecase name
+ ((or string symbol)
+ ;; Try looking under the given name and the all-uppercase name
+ (or (find-package (string name))
+ (find-package (string-upcase (string name)))))
+ ((cons)
+ ;; If 'name' is a list, it's actually a fully-qualified path
+ (or (find-proto-package (first name))
+ (find-proto-package (format nil "~{~A~^.~}" name))))))
+
;; "class-name" -> "ClassName", ("ClassName")
;; "outer-class.inner-class" -> "InnerClass", ("OuterClass" "InnerClass")
(defun class-name->proto (x)
(camel-case (format nil "~A" x) *proto-name-separators*))))
(nx (car (last xs)))
(name (remove-if-not #'alphanumericp (camel-case nx *proto-name-separators*))))
- (values name (append ns (list name)))))
+ (values name (append ns (list name))
+ ;; This might be the name of a package, too
+ (format nil "~{~A~^.~}" (butlast xs)))))
;; "enum-value" -> "ENUM_VALUE", ("ENUM_VALUE")
;; "class-name.enum-value" -> "ENUM_VALUE", ("ClassName" "ENUM_VALUE")
(name (remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
(format nil "~{~A~^_~}"
(split-string nx :separators *proto-name-separators*)))))
- (values name (append ns (list name)))))
+ (values name (append ns (list name))
+ (format nil "~{~A~^.~}" (butlast xs)))))
;; "slot-name" -> "slot_name", ("slot_name") or "slotName", ("slotName")
;; "class-name.slot-name" -> "Class.slot_name", ("ClassName" "slot_name")
(remove-if-not #'(lambda (x) (or (alphanumericp x) (eql x #\_)))
(format nil "~{~A~^_~}"
(split-string nx :separators *proto-name-separators*))))))
- (values name (append ns (list name)))))
+ (values name (append ns (list name))
+ (format nil "~{~A~^.~}" (butlast xs)))))
;; "ClassName" -> 'class-name
This resolves Protobufs qualified names as best as it can."
(let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
:separators '(#\.)))
- (pkg (and (cdr xs) (find-package (first xs))))
- (package (or pkg package))
- (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
- (values (if package (intern name package) (make-symbol name)) package xs)))
+ (pkg1 (and (cdr xs) (find-proto-package (first xs))))
+ (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
+ (package (or pkg1 pkgn package))
+ (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
+ (values (if package (intern name package) (make-symbol name)) package xs
+ ;; This might be the name of a package, too
+ (format nil "~{~A~^.~}" (butlast xs)))))
;; "ENUM_VALUE" -> :enum-value
;; "cl-user.ENUM_VALUE" -> :enum-value
This resolves Protobufs qualified names as best as it can."
(let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
:separators '(#\.)))
- (pkg (and (cdr xs) (find-package (first xs))))
- (package (or pkg package))
- (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
- (values (kintern name) package xs)))
+ (pkg1 (and (cdr xs) (find-proto-package (first xs))))
+ (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
+ (package (or pkg1 pkgn package))
+ (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
+ (values (kintern name) package xs
+ (format nil "~{~A~^.~}" (butlast xs)))))
;; "slot_name" or "slotName" -> 'slot-name
;; "cl-user.slot_name" or "cl-user.slotName" -> 'cl-user::slot-name
This resolves Protobufs qualified names as best as it can."
(let* ((xs (split-string (substitute #\- #\_ (uncamel-case x))
:separators '(#\.)))
- (pkg (and (cdr xs) (find-package (first xs))))
- (package (or pkg package))
- (name (format nil "~{~A~^.~}" (if pkg (cdr xs) xs))))
- (values (if package (intern name package) (make-symbol name)) package xs)))
+ (pkg1 (and (cdr xs) (find-proto-package (first xs))))
+ (pkgn (and (cdr xs) (find-proto-package (butlast xs))))
+ (package (or pkg1 pkgn package))
+ (name (format nil "~{~A~^.~}" (if pkg1 (cdr xs) (if pkgn (last xs) xs)))))
+ (values (if package (intern name package) (make-symbol name)) package xs
+ (format nil "~{~A~^.~}" (butlast xs)))))
+
+;;; Warnings
(define-condition protobufs-warning (warning simple-condition) ())
`(let ((dspec:*redefinition-action* :quiet)) ,@body))
\f
-;;; Floating point utilities
+;;; Portable floating point utilities
#+(or abcl allegro cmu sbcl lispworks)
(defun single-float-bits (x)
projects / cl-protobufs.git / commitdiff