1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Confidential and proprietary information of ITA Software, Inc. ;;;
5 ;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Examples, for manual testing
16 ;;--- Turn these into a test suite
19 (setq cschema (proto:write-protobuf-schema-for-classes
20 '(qres-core::legacy-pnr
21 qres-core::legacy-pnr-pax
22 qres-core::legacy-pnr-segment
23 qres-core::legacy-pnr-pax-segment)
24 :slot-filter #'quake::quake-slot-filter
25 :type-filter #'quake::quake-type-filter
26 :enum-filter #'quake::quake-enum-filter
27 :value-filter #'quake::quake-value-filter))
29 (proto:serialize-object-to-stream pnr cschema :stream nil)
33 (setq pschema (proto:write-protobuf-schema-for-classes
34 '(proto:protobuf proto:protobuf-option
35 proto:protobuf-enum proto:protobuf-enum-value
36 proto:protobuf-message proto:protobuf-field proto:protobuf-extension
37 proto:protobuf-service proto:protobuf-rpc)))
39 (setq pser (proto:serialize-object-to-stream pschema pschema :stream nil))
40 (describe (proto:deserialize-object 'proto:protobuf pschema pser 0))
42 (proto:print-text-format pschema pschema)
43 (proto:print-text-format (proto:deserialize-object 'proto:protobuf pschema pser 0) pschema)
47 (defclass proto-test1 ()
48 ((intval :type (integer -2147483648 +2147483647)
51 (defclass proto-test2 ()
52 ((intval :type (or null (integer -2147483648 +2147483647))
57 (defclass proto-test3 ()
58 ((intval :type (or null (integer -2147483648 +2147483647))
60 (strval :type (or null string)
62 (recval :type proto-test1
65 (defclass proto-test4 ()
66 ((intval :type (or null (integer -2147483648 +2147483647))
68 (strval :type (or null string)
70 (recval :type proto-test2
73 (defclass proto-test5 ()
74 ((color :type (member :red :green :blue)
76 (intvals :type (list-of integer)
79 (strvals :type (list-of string)
83 (setq tschema (proto:write-protobuf-schema-for-classes
84 '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5)))
86 (setq test1 (make-instance 'proto-test1 :intval 150))
87 (setq test2 (make-instance 'proto-test2 :strval "testing"))
88 (setq test3 (make-instance 'proto-test3 :recval test1))
89 (setq test4 (make-instance 'proto-test4 :recval test2))
90 (setq test5 (make-instance 'proto-test5 :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
92 (setq tser1 (proto:serialize-object-to-stream test1 tschema :stream nil))
93 (equalp tser1 #(#x08 #x96 #x01))
94 (describe (proto:deserialize-object 'proto-test1 tschema tser1 0))
96 (setq tser2 (proto:serialize-object-to-stream test2 tschema :stream nil))
97 (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
98 (describe (proto:deserialize-object 'proto-test2 tschema tser2 0))
100 (setq tser3 (proto:serialize-object-to-stream test3 tschema :stream nil))
101 (equalp tser3 #(#x1A #x03 #x08 #x96 #x01))
102 (describe (proto:deserialize-object 'proto-test3 tschema tser3 0))
103 (describe (slot-value (proto:deserialize-object 'proto-test3 tschema tser3 0) 'recval))
105 (setq tser4 (proto:serialize-object-to-stream test4 tschema :stream nil))
106 (equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
107 (describe (proto:deserialize-object 'proto-test4 tschema tser4 0))
108 (describe (slot-value (proto:deserialize-object 'proto-test4 tschema tser4 0) 'recval))
110 (setq tser5 (proto:serialize-object-to-stream test5 tschema :stream nil))
111 (equalp tser5 #(#x08 #x01
112 #x10 #x04 #x02 #x03 #x05 #x07
113 #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))
114 (describe (proto:deserialize-object 'proto-test5 tschema tser5 0))
116 (equalp (mapcar #'proto-impl:zig-zag-encode32
117 '(0 -1 1 -2 2 -2147483648 2147483647))
118 '(0 1 2 3 4 4294967295 4294967294))
119 (equalp (mapcar #'proto-impl:zig-zag-encode64
120 '(0 -1 1 -2 2 -2147483648 2147483647 -1152921504606846976 1152921504606846975))
121 '(0 1 2 3 4 4294967295 4294967294 2305843009213693951 2305843009213693950))
123 (proto:print-text-format test1 tschema)
124 (proto:print-text-format (proto:deserialize-object 'proto-test1 tschema tser1 0) tschema)
126 (proto:print-text-format test2 tschema)
127 (proto:print-text-format (proto:deserialize-object 'proto-test2 tschema tser2 0) tschema)
129 (proto:print-text-format test3 tschema)
130 (proto:print-text-format (proto:deserialize-object 'proto-test3 tschema tser3 0) tschema)
132 (proto:print-text-format test4 tschema)
133 (proto:print-text-format (proto:deserialize-object 'proto-test4 tschema tser4 0) tschema)
135 (proto:print-text-format test5 tschema)
136 (proto:print-text-format (proto:deserialize-object 'proto-test5 tschema tser5 0) tschema)
140 (let* ((enums (list (make-instance 'proto:protobuf-enum
142 :values (list (make-instance 'proto:protobuf-enum-value
146 (make-instance 'proto:protobuf-enum-value
150 (make-instance 'proto:protobuf-enum-value
154 (msgs (list (make-instance 'proto:protobuf-message
156 :enums (list (make-instance 'proto:protobuf-enum
158 :values (list (make-instance 'proto:protobuf-enum-value
162 (make-instance 'proto:protobuf-enum-value
166 :fields (list (make-instance 'proto:protobuf-field
171 (make-instance 'proto:protobuf-field
177 (rpcs (list (make-instance 'proto:protobuf-rpc
180 :output-type "Color")
181 (make-instance 'proto:protobuf-rpc
185 :options (list (make-instance 'protobuf-option
186 :name "deadline" :value "1.0")))))
187 (svcs (list (make-instance 'proto:protobuf-service
190 (proto (make-instance 'proto:protobuf
192 :imports '("descriptor.proto")
196 ;; The output should be example the same as the output of 'write-protobuf' below
197 (proto:write-protobuf proto))
201 (proto:define-proto color-wheel
203 :import "descriptor.proto"
204 :documentation "Color wheel example")
205 (proto:define-enum color-name
206 (:documentation "A color name")
210 (proto:define-message color
212 :documentation "Color and contrast")
213 (proto:define-enum contrast-name
214 (:documentation "A contrast name")
217 (color :type color-name)
218 (contrast :type (or null contrast-name) :default :low))
219 (proto:define-service color-wheel
220 (:documentation "Get and set colors")
221 (get-color nil color)
222 (set-color color color :options ("deadline" "1.0"))))
225 (DEFTYPE COLOR-NAME () '(MEMBER :RED :GREEN :BLUE))
226 (DEFTYPE CONTRAST-NAME () '(MEMBER :LOW :HIGH))
228 ((COLOR :TYPE COLOR-NAME :ACCESSOR COLOR-COLOR :INITARG :COLOR)
229 (CONTRAST :TYPE (OR NULL CONTRAST-NAME) :ACCESSOR COLOR-CONTRAST :INITARG :CONTRAST :INITFORM :LOW)))
230 (DEFVAR *COLOR-WHEEL*
231 (MAKE-INSTANCE 'PROTOBUF
235 :IMPORTS '("descriptor.proto")
238 :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
241 :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
242 :NAME "RED" :INDEX 1 :VALUE :RED)
243 (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
244 :NAME "GREEN" :INDEX 2 :VALUE :GREEN)
245 (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
246 :NAME "BLUE" :INDEX 3 :VALUE :BLUE))))
247 :MESSAGES (LIST (MAKE-INSTANCE 'PROTOBUF-MESSAGE
251 :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
253 :CLASS 'CONTRAST-NAME
254 :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
255 :NAME "LOW" :INDEX 1 :VALUE :LOW)
256 (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
257 :NAME "HIGH" :INDEX 100 :VALUE :HIGH))))
259 :FIELDS (LIST (MAKE-INSTANCE 'PROTOBUF-FIELD
268 (MAKE-INSTANCE 'PROTOBUF-FIELD
271 :CLASS 'CONTRAST-NAME
277 :SERVICES (LIST (MAKE-INSTANCE 'PROTOBUF-SERVICE
280 :RPCS (LIST (MAKE-INSTANCE 'PROTOBUF-RPC
286 (MAKE-INSTANCE 'PROTOBUF-RPC
291 :OPTIONS (LIST (MAKE-INSTANCE 'PROTOBUF-OPTION
292 :NAME "deadline" :VALUE "1.0")))))))))
294 ;; The output should be example the same as the output of 'write-protobuf' above
295 (proto:write-protobuf *color-wheel*)
297 ;; How does the Lisp version look?
298 (proto:write-protobuf *color-wheel* :type :lisp)
300 (setq clr (make-instance 'color :color :red))
301 (setq cser (proto:serialize-object-to-stream clr *color-wheel* :stream nil))
302 (proto:print-text-format clr *color-wheel*)
303 (proto:print-text-format (proto:deserialize-object 'color *color-wheel* cser 0) *color-wheel*)
307 (let ((ps "package ita.color;
309 import \"descriptor.proto\";
322 required ColorName color = 1;
323 optional ContrastName contrast = 2 [default = LOW];
327 rpc GetColor () returns (Color);
328 rpc SetColor (Color) returns (Color) {
329 option deadline = \"1.0\";
332 (with-input-from-string (s ps)
333 (setq ppp (parse-protobuf-from-stream s))))
335 (proto:write-protobuf ppp)
336 (proto:write-protobuf ppp :type :lisp)
340 (proto:define-proto read-air-reservation (:package qres-core)
341 (proto:define-message read-air-reservation-request ()
342 (proto:define-message air-reservation-spec ()
343 (locator :type (list-of pnr-locator))
344 (customer :type (or null string))
345 (contract-group-id :type (or null integer))
346 (last-name :type (or null string))
347 (first-name :type (or null string))
348 (phone-number :type (or null string))
349 (email-address :type (or null string))
350 (cc-number :type (or null string))
351 (ticket-number :type (or null string))
352 (ff-account :type (or null ff-account))
353 (flights :type (list-of flight-spec)))
354 (proto:define-message pnr-locator ()
355 (system :type string)
356 (locator :type string))
357 (proto:define-message ff-account ()
358 (carrier :type string)
359 (number :type string))
360 (proto:define-message flight-spec ()
361 (carrier :type string)
362 (flight-number :type integer)
363 (suffix :type (or null string))
365 (origin :type (or null string))
366 (destination :type (or null string)))
367 (spec :type air-reservation-spec))
368 (proto:define-message read-air-reservation-response ()
370 (proto:define-service read-air-reservation ()
371 (read-air-reservation read-air-reservation-request read-air-reservation-response)))
373 (proto:write-protobuf *read-air-reservation*)
374 (proto:write-protobuf *read-air-reservation* :type :lisp)