;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
-;;; Confidential and proprietary information of ITA Software, Inc. ;;;
+;;; Free Software published under an MIT-like license. See LICENSE ;;;
;;; ;;;
-;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay ;;;
;;; ;;;
(in-package "PROTO-IMPL")
-;;; Examples, for manual testing
+;;; Some examples; also for some for manual testing
#||
-(setq cschema (proto:write-protobuf-schema-for-classes '(qres-core::legacy-pnr
- qres-core::legacy-pnr-pax
- qres-core::legacy-pnr-segment
- qres-core::legacy-pnr-pax-segment)
- :slot-filter #'quake::quake-slot-filter
- :type-filter #'quake::quake-type-filter
- :enum-filter #'quake::quake-enum-filter
- :value-filter #'quake::quake-value-filter))
-
-(proto:serialize-object-to-stream pnr cschema :stream nil)
+;; A pretty useful subset of air schedule objects
+(setq sched-schema (proto:generate-schema-for-classes
+ '(quux::zoned-time
+ sched::scheduled-flight
+ sched::flight-designator
+ sched::flight-key
+ sched::scheduled-segment
+ sched::segment-key
+ sched::subsegment-key
+ sched::scheduled-leg
+ sched::leg-key
+ sched::revision-entry)
+ :package :qres-sched
+ :slot-filter #'quake::quake-slot-filter
+ :type-filter #'quake::quake-type-filter
+ :enum-filter #'quake::quake-enum-filter
+ :value-filter #'quake::quake-value-filter))
+
+(proto:write-schema sched-schema)
+(proto:write-schema sched-schema :type :lisp)
||#
+
#||
-(setq pschema (proto:write-protobuf-schema-for-classes '(proto:protobuf
- proto:protobuf-message proto:protobuf-field
- proto:protobuf-enum proto:protobuf-enum-value)))
+;; A pretty useful subset of geographic business data
+(defclass geodata ()
+ ;; This one stores the data in lists
+ ((countries :type (proto:list-of qres-core::country)
+ :initform ()
+ :initarg :countries)
+ (regions :type (proto:list-of qres-core::region)
+ :initform ()
+ :initarg :regions)
+ (cities :type (proto:list-of qres-core::city)
+ :initform ()
+ :initarg :cities)
+ (airports :type (proto:list-of qres-core::airport)
+ :initform ()
+ :initarg :airports)))
+
+(defclass geodata-v ()
+ ;; This one stores the data in vectors
+ ((countries :type (proto:vector-of qres-core::country)
+ :initform #()
+ :initarg :countries)
+ (regions :type (proto:vector-of qres-core::region)
+ :initform #()
+ :initarg :regions)
+ (cities :type (proto:vector-of qres-core::city)
+ :initform #()
+ :initarg :cities)
+ (airports :type (proto:vector-of qres-core::airport)
+ :initform #()
+ :initarg :airports)))
+
+(setq *geodata* (proto:generate-schema-for-classes
+ '(qres-core::country
+ qres-core::region
+ qres-core::region-key
+ qres-core::city
+ qres-core::airport
+ qres-core::timezone
+ qres-core::tz-variation
+ qres-core::currency
+ qres-core::country-currencies
+ qres-core::carrier
+ geodata geodata-v)
+ :install t))
+
+(proto:write-schema *geodata*)
+(proto:write-schema *geodata* :type :lisp)
+
+;; Load the data
+(let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
+ (regions (loop for v being the hash-values of (qres-core::region-business-data) collect v))
+ (cities (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
+ (airports (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v))))
+ (setq geodata (make-instance 'geodata
+ :countries countries
+ :regions regions
+ :cities cities
+ :airports airports)
+ geodata-v (make-instance 'geodata-v
+ :countries (make-array (length countries) :fill-pointer t :initial-contents countries)
+ :regions (make-array (length regions) :fill-pointer t :initial-contents regions)
+ :cities (make-array (length cities) :fill-pointer t :initial-contents cities)
+ :airports (make-array (length airports) :fill-pointer t :initial-contents airports))))
+
+(dolist (class '(qres-core::country
+ qres-core::region
+ qres-core::region-key
+ qres-core::city
+ qres-core::airport
+ qres-core::timezone
+ qres-core::tz-variation
+ qres-core::currency
+ qres-core::country-currencies
+ qres-core::carrier
+ geodata geodata-v))
+ (let ((message (proto:find-message *geodata* class)))
+ (eval (proto-impl:generate-object-size message))
+ (eval (proto-impl:generate-serializer message))
+ (eval (proto-impl:generate-deserializer message))))
+
+(time (progn (setq gser (proto:serialize-object-to-bytes geodata 'geodata)) nil))
+(time (proto:deserialize-object 'geodata gser))
-(setq pser (proto:serialize-object-to-stream pschema pschema :stream nil))
-(describe (proto:deserialize-object 'proto:protobuf pschema pser))
+(equalp gser (proto:serialize-object-to-bytes
+ (proto:deserialize-object 'geodata gser) 'geodata))
-(proto:print-text-format pschema pschema)
-(proto:print-text-format (proto:deserialize-object 'proto:protobuf pschema pser) pschema)
+(time (progn (setq gser-v (proto:serialize-object-to-bytes geodata-v 'geodata-v)) nil))
+(time (proto:deserialize-object 'geodata-v gser-v))
+
+(equalp gser-v (proto:serialize-object-to-bytes
+ (proto:deserialize-object 'geodata-v gser-v) 'geodata-v))
+
+(equalp gser gser-v)
||#
+
#||
-(defclass proto-test1 ()
- ((intval :type (integer -2147483648 +2147483647)
- :initarg :intval)))
-
-(defclass proto-test2 ()
- ((intval :type (or null (integer -2147483648 +2147483647))
- :initarg :intval)
- (strval :type string
- :initarg :strval)))
-
-(defclass proto-test3 ()
- ((intval :type (or null (integer -2147483648 +2147483647))
- :initarg :intval)
- (strval :type (or null string)
- :initarg :strval)
- (recval :type proto-test1
- :initarg :recval)))
-
-(defclass proto-test4 ()
- ((intval :type (or null (integer -2147483648 +2147483647))
- :initarg :intval)
- (strval :type (or null string)
- :initarg :strval)
- (recval :type proto-test2
- :initarg :recval)))
-
-(defclass proto-test5 ()
- ((color :type (member :red :green :blue)
- :initarg :color)
- (intvals :type (list-of integer)
- :initform ()
- :initarg :intvals)
- (strvals :type (list-of string)
- :initform ()
- :initarg :strvals)))
-
-(setq tschema (proto:write-protobuf-schema-for-classes
- '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5)))
-
-(setq test1 (make-instance 'proto-test1 :intval 150))
-(setq test2 (make-instance 'proto-test2 :strval "testing"))
-(setq test3 (make-instance 'proto-test3 :recval test1))
-(setq test4 (make-instance 'proto-test4 :recval test2))
-(setq test5 (make-instance 'proto-test5 :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
-
-(setq tser1 (proto:serialize-object-to-stream test1 tschema :stream nil))
-(equalp tser1 #(#x08 #x96 #x01))
-(describe (proto:deserialize-object 'proto-test1 tschema tser1))
-
-(setq tser2 (proto:serialize-object-to-stream test2 tschema :stream nil))
-(equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
-(describe (proto:deserialize-object 'proto-test2 tschema tser2))
-
-(setq tser3 (proto:serialize-object-to-stream test3 tschema :stream nil))
-(equalp tser3 #(#x1A #x03 #x08 #x96 #x01))
-(describe (proto:deserialize-object 'proto-test3 tschema tser3))
-(describe (slot-value (proto:deserialize-object 'proto-test3 tschema tser3) 'recval))
-
-(setq tser4 (proto:serialize-object-to-stream test4 tschema :stream nil))
-(equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
-(describe (proto:deserialize-object 'proto-test4 tschema tser4))
-(describe (slot-value (proto:deserialize-object 'proto-test4 tschema tser4) 'recval))
-
-(setq tser5 (proto:serialize-object-to-stream test5 tschema :stream nil))
-(equalp tser5 #(#x08 #x01
- #x10 #x04 #x02 #x03 #x05 #x07
- #x1A #x03 #x74 #x77 #x6F #x1A #x05 #x74 #x68 #x72 #x65 #x65 #x1A #x04 #x66 #x69 #x76 #x65 #x1A #x05 #x73 #x65 #x76 #x65 #x6E))
-(describe (proto:deserialize-object 'proto-test5 tschema tser5))
-
-(equalp (mapcar #'proto-impl:zig-zag-encode32
- '(0 -1 1 -2 2 -2147483648 2147483647))
- '(0 1 2 3 4 4294967295 4294967294))
-(equalp (mapcar #'proto-impl:zig-zag-encode64
- '(0 -1 1 -2 2 -2147483648 2147483647 -1152921504606846976 1152921504606846975))
- '(0 1 2 3 4 4294967295 4294967294 2305843009213693951 2305843009213693950))
-
-(proto:print-text-format test1 tschema)
-(proto:print-text-format (proto:deserialize-object 'proto-test1 tschema tser1) tschema)
-
-(proto:print-text-format test2 tschema)
-(proto:print-text-format (proto:deserialize-object 'proto-test2 tschema tser2) tschema)
-
-(proto:print-text-format test3 tschema)
-(proto:print-text-format (proto:deserialize-object 'proto-test3 tschema tser3) tschema)
-
-(proto:print-text-format test4 tschema)
-(proto:print-text-format (proto:deserialize-object 'proto-test4 tschema tser4) tschema)
-
-(proto:print-text-format test5 tschema)
-(proto:print-text-format (proto:deserialize-object 'proto-test5 tschema tser5) tschema)
+;; Lisp lists :-)
+(proto:define-schema typed-list ()
+ (proto:define-message typed-list ()
+ (string-car :type (or null string) :reader string-car)
+ (symbol-car :type (or null string) :reader symbol-car)
+ (integer-car :type (or null integer) :reader integer-car)
+ (float-car :type (or null single-float) :reader float-car)
+ (list-car :type (or null typed-list) :reader list-car)
+ (list-cdr :type (or null typed-list) :reader list-cdr)))
+
+(defun string-car (x)
+ (and (stringp (car x)) (car x)))
+
+(defun symbol-car (x)
+ (and (symbolp (car x)) (symbol-name (car x))))
+
+(defun integer-car (x)
+ (and (integerp (car x)) (car x)))
+
+(defun float-car (x)
+ (and (floatp (car x)) (car x)))
+
+(defun list-car (x)
+ (etypecase (car x)
+ ((or string symbol integer float) nil)
+ (list (car x))))
+
+(defun list-cdr (x)
+ (assert (listp (cdr x)) ())
+ (cdr x))
+
+(let ((list '("this" "is" "a" ("nested" "test"))))
+ (proto:serialize-object-to-bytes list 'typed-list)
+ (proto:print-text-format list 'typed-list)
+ (proto:print-text-format list 'typed-list :suppress-line-breaks t)
+ (let ((text (with-output-to-string (s)
+ (proto:print-text-format list 'typed-list :stream s))))
+ (with-input-from-string (s text)
+ (proto:parse-text-format 'typed-list :stream s))))
+
+(let ((list '((1 one) (2 two) (3 three))))
+ (proto:serialize-object-to-bytes list 'typed-list)
+ (proto:print-text-format list 'typed-list)
+ (proto:print-text-format list 'typed-list :suppress-line-breaks t)
+ (let ((text (with-output-to-string (s)
+ (proto:print-text-format list 'typed-list :stream s))))
+ (with-input-from-string (s text)
+ (proto:parse-text-format 'typed-list :stream s))))
||#
+
#||
-(let* ((enums (list (make-instance 'proto:protobuf-enum
- :name "ColorName"
- :values (list (make-instance 'proto:protobuf-enum-value
- :name "RED"
- :index 1
- :value :red)
- (make-instance 'proto:protobuf-enum-value
- :name "GREEN"
- :index 2
- :value :green)
- (make-instance 'proto:protobuf-enum-value
- :name "BLUE"
- :index 3
- :value :blue)))))
- (msgs (list (make-instance 'proto:protobuf-message
- :name "Color"
- :enums (list (make-instance 'proto:protobuf-enum
- :name "ContrastName"
- :values (list (make-instance 'proto:protobuf-enum-value
- :name "LOW"
- :index 1
- :value :high)
- (make-instance 'proto:protobuf-enum-value
- :name "HIGH"
- :index 100
- :value :low))))
- :fields (list (make-instance 'proto:protobuf-field
- :name "color"
- :type "Color"
- :required :required
- :index 1)
- (make-instance 'proto:protobuf-field
- :name "contrast"
- :type "Contrast"
- :required :optional
- :index 2
- :default "LOW")))))
- (rpcs (list (make-instance 'proto:protobuf-rpc
- :name "GetColor"
- :input-type nil
- :output-type "Color")
- (make-instance 'proto:protobuf-rpc
- :name "SetColor"
- :input-type "Color"
- :output-type "Color")))
- (svcs (list (make-instance 'proto:protobuf-service
- :name "ColorWheel"
- :rpcs rpcs)))
- (proto (make-instance 'proto:protobuf
- :package "ita.color"
- :imports '("descriptor.proto")
- :enums enums
- :messages msgs
- :services svcs)))
- ;; The output should be example the same as the output of 'write-protobuf' below
- (proto:write-protobuf proto *standard-output*))
+;; Extension example
+(proto:define-schema color-wheel
+ (:package color-wheel
+ :optimize :speed
+ :documentation "Color wheel example")
+ (proto:define-message color-wheel
+ (:conc-name color-wheel-)
+ (name :type string)
+ (colors :type (proto:list-of color) :default ()))
+ (proto:define-message color
+ (:conc-name color-
+ :documentation "A (named) color")
+ (name :type (or string null))
+ (r-value :type integer)
+ (g-value :type integer)
+ (b-value :type integer)
+ (proto:define-extension 1000 max))
+ (proto:define-extend color ()
+ ((opacity 1000) :type (or null integer)))
+ (proto:define-message get-color-request ()
+ (wheel :type color-wheel)
+ (name :type string))
+ (proto:define-message add-color-request ()
+ (wheel :type color-wheel)
+ (color :type color))
+ (proto:define-service color-wheel ()
+ (get-color (get-color-request => color)
+ :options (:deadline 1.0)
+ :documentation "Look up a color by name")
+ (add-color (add-color-request => color)
+ :options (:deadline 1.0)
+ :documentation "Add a new color to the wheel")))
+
+(proto:write-schema *color-wheel*)
+(proto:write-schema *color-wheel* :type :lisp)
+
+(let* ((wheel (make-instance 'color-wheel :name "Colors"))
+ (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
+ (rqst1 (make-instance 'add-color-request :wheel wheel :color color1))
+ (color2 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
+ (rqst2 (make-instance 'add-color-request :wheel wheel :color color2)))
+ (setf (color-opacity color2) 50)
+ (progn
+ (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity))
+ (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color-request)))
+ (print ser1)
+ (proto:print-text-format rqst1)
+ (proto:print-text-format (proto:deserialize-object 'add-color-request ser1))))
+ (progn
+ (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity))
+ (let ((ser2 (proto:serialize-object-to-bytes rqst2 'add-color-request)))
+ (print ser2)
+ (proto:print-text-format rqst2)
+ (proto:print-text-format (proto:deserialize-object 'add-color-request ser2)))))
||#
+
#||
-(makunbound '*color-wheel*)
-
-(proto:define-proto color-wheel (:package ita.color
- :import "descriptor.proto")
- (proto:define-enum color-name ()
- red
- green
- blue)
- (proto:define-message color (:conc-name color-)
- (proto:define-enum contrast-name ()
- (low 1)
- (high 100))
- (color :type color)
- (contrast :type (or null contrast) :default :low))
- (proto:define-service color-wheel ()
- (get-color nil color)
- (set-color color color)))
-
-=> (PROGN
- (DEFTYPE COLOR-NAME () '(MEMBER :RED :GREEN :BLUE))
- (DEFTYPE CONTRAST-NAME () '(MEMBER :LOW :HIGH))
- (DEFCLASS COLOR ()
- ((COLOR :TYPE COLOR :ACCESSOR COLOR-COLOR :INITARG :COLOR)
- (CONTRAST :TYPE (OR NULL CONTRAST) :ACCESSOR COLOR-CONTRAST :INITARG :CONTRAST :INITFORM :LOW)))
- (DEFVAR *COLOR-WHEEL*
- (MAKE-INSTANCE 'PROTOBUF
- :NAME "ColorWheel"
- :PACKAGE "ita.color"
- :IMPORTS '("descriptor.proto")
- :SYNTAX NIL
- :OPTIONS 'NIL
- :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
- :NAME "ColorName"
- :CLASS 'COLOR-NAME
- :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
- :NAME "RED"
- :INDEX 1
- :VALUE :RED)
- (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
- :NAME "GREEN"
- :INDEX 2
- :VALUE :GREEN)
- (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
- :NAME "BLUE"
- :INDEX 3
- :VALUE :BLUE))))
- :MESSAGES (LIST (MAKE-INSTANCE 'PROTOBUF-MESSAGE
- :NAME "Color"
- :CLASS 'COLOR
- :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
- :NAME "ContrastName"
- :CLASS 'CONTRAST-NAME
- :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
- :NAME "LOW"
- :INDEX 1
- :VALUE :LOW)
- (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
- :NAME "HIGH"
- :INDEX 100
- :VALUE :HIGH))))
- :MESSAGES (LIST)
- :FIELDS (LIST (MAKE-INSTANCE 'PROTOBUF-FIELD
- :NAME "color"
- :TYPE "Color"
- :CLASS 'COLOR
- :REQUIRED :REQUIRED
- :INDEX 1
- :VALUE 'COLOR
- :DEFAULT NIL
- :PACKED NIL)
- (MAKE-INSTANCE 'PROTOBUF-FIELD
- :NAME "contrast"
- :TYPE "Contrast"
- :CLASS 'CONTRAST
- :REQUIRED :OPTIONAL
- :INDEX 2
- :VALUE 'CONTRAST
- :DEFAULT "LOW"
- :PACKED NIL))))
- :SERVICES (LIST (MAKE-INSTANCE 'PROTOBUF-SERVICE
- :NAME "ColorWheel"
- :RPCS (LIST (MAKE-INSTANCE 'PROTOBUF-RPC
- :NAME "GetColor"
- :INPUT-TYPE NIL
- :OUTPUT-TYPE "Color")
- (MAKE-INSTANCE 'PROTOBUF-RPC
- :NAME "SetColor"
- :INPUT-TYPE "Color"
- :OUTPUT-TYPE "Color")))))))
-
-;; The output should be example the same as the output of 'write-protobuf' above
-(proto:write-protobuf *color-wheel* *standard-output*)
+;; Group example
+(proto:define-schema color-wheel1
+ (:package color-wheel
+ ;; :optimize :speed
+ :documentation "Color wheel example, with nested message")
+ (proto:define-type-alias date ()
+ :lisp-type integer
+ :proto-type string
+ :serializer integer-to-date
+ :deserializer date-to-integer)
+ (proto:define-message color-wheel1 ()
+ (proto:define-message metadata1 ()
+ (author :type (or null string))
+ (revision :type (or null string))
+ (date :type (or null date)))
+ (name :type string)
+ (colors :type (proto:list-of color1))
+ (metadata1 :type (or null metadata1)))
+ (proto:define-message color1 ()
+ (name :type (or null string))
+ (r-value :type integer)
+ (g-value :type integer)
+ (b-value :type integer))
+ (proto:define-message add-color1 ()
+ (wheel :type color-wheel1)
+ (color :type color1)))
+
+(proto:define-schema color-wheel2
+ (:package color-wheel
+ ;; :optimize :speed
+ :documentation "Color wheel example, with group")
+ (proto:define-type-alias date ()
+ :lisp-type integer
+ :proto-type string
+ :serializer integer-to-date
+ :deserializer date-to-integer)
+ (proto:define-message color-wheel2 ()
+ (name :type string)
+ (colors :type (proto:list-of color2))
+ (proto:define-group metadata2
+ (:index 3
+ :arity :optional)
+ (author :type (or null string))
+ (revision :type (or null string))
+ (date :type (or null date))))
+ (proto:define-message color2 ()
+ (name :type (or null string))
+ (r-value :type integer)
+ (g-value :type integer)
+ (b-value :type integer))
+ (proto:define-message add-color2 ()
+ (wheel :type color-wheel2)
+ (color :type color2)))
+
+(defun integer-to-date (date)
+ (with-output-to-string (s)
+ (quux:write-local-date (quux:get-local-time date) s :format :dd-mth-yyyy)))
+
+(defun date-to-integer (string)
+ (quux:parse-local-date string))
+
+(proto:write-schema *color-wheel1*)
+(proto:write-schema *color-wheel2*)
+
+(let* ((meta1 (make-instance 'metadata1 :revision "1.0" :date (date-to-integer "12-FEB-1958")))
+ (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata1 meta1))
+ (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
+ (rqst1 (make-instance 'add-color1 :wheel wheel1 :color color1))
+ (meta2 (make-instance 'metadata2 :revision "1.0" :date (date-to-integer "12-FEB-1958")))
+ (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata2 meta2))
+ (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
+ (rqst2 (make-instance 'add-color2 :wheel wheel2 :color color2)))
+ (progn
+ (format t "~2&Nested")
+ (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color1)))
+ (print ser1)
+ (proto:print-text-format rqst1)
+ (proto:print-text-format (proto:deserialize-object 'add-color1 ser1))))
+ (progn
+ (format t "~2&Group")
+ (let ((ser2 (proto:serialize-object-to-bytes rqst2 'add-color2)))
+ (print ser2)
+ (proto:print-text-format rqst2)
+ (proto:print-text-format (proto:deserialize-object 'add-color2 ser2)))))
||#
projects / cl-protobufs.git / blobdiff