1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Some examples; also for some for manual testing
17 ;; A pretty useful subset of air schedule objects
18 (setq sched-schema (proto:generate-schema-for-classes
20 sched::scheduled-flight
21 sched::flight-designator
23 sched::scheduled-segment
28 sched::revision-entry)
30 :slot-filter #'quake::quake-slot-filter
31 :type-filter #'quake::quake-type-filter
32 :enum-filter #'quake::quake-enum-filter
33 :value-filter #'quake::quake-value-filter))
35 (proto:write-schema sched-schema)
36 (proto:write-schema sched-schema :type :lisp)
41 ;; A pretty useful subset of geographic business data
43 ;; This one stores the data in lists
44 ((countries :type (proto:list-of qres-core::country)
47 (regions :type (proto:list-of qres-core::region)
50 (cities :type (proto:list-of qres-core::city)
53 (airports :type (proto:list-of qres-core::airport)
57 (defclass geodata-v ()
58 ;; This one stores the data in vectors
59 ((countries :type (proto:vector-of qres-core::country)
62 (regions :type (proto:vector-of qres-core::region)
65 (cities :type (proto:vector-of qres-core::city)
68 (airports :type (proto:vector-of qres-core::airport)
72 (setq *geodata* (proto:generate-schema-for-classes
79 qres-core::tz-variation
81 qres-core::country-currencies
86 (proto:write-schema *geodata*)
87 (proto:write-schema *geodata* :type :lisp)
90 (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
91 (regions (loop for v being the hash-values of (qres-core::region-business-data) collect v))
92 (cities (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
93 (airports (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v))))
94 (setq geodata (make-instance 'geodata
99 geodata-v (make-instance 'geodata-v
100 :countries (make-array (length countries) :fill-pointer t :initial-contents countries)
101 :regions (make-array (length regions) :fill-pointer t :initial-contents regions)
102 :cities (make-array (length cities) :fill-pointer t :initial-contents cities)
103 :airports (make-array (length airports) :fill-pointer t :initial-contents airports))))
105 (dolist (class '(qres-core::country
107 qres-core::region-key
111 qres-core::tz-variation
113 qres-core::country-currencies
116 (let ((message (proto:find-message *geodata* class)))
117 (eval (proto-impl:generate-object-size message))
118 (eval (proto-impl:generate-serializer message))
119 (eval (proto-impl:generate-deserializer message))))
121 (time (progn (setq gser (proto:serialize-object-to-bytes geodata 'geodata)) nil))
122 (time (proto:deserialize-object 'geodata gser))
124 (equalp gser (proto:serialize-object-to-bytes
125 (proto:deserialize-object 'geodata gser) 'geodata))
127 (time (progn (setq gser-v (proto:serialize-object-to-bytes geodata-v 'geodata-v)) nil))
128 (time (proto:deserialize-object 'geodata-v gser-v))
130 (equalp gser-v (proto:serialize-object-to-bytes
131 (proto:deserialize-object 'geodata-v gser-v) 'geodata-v))
139 (proto:define-schema typed-list ()
140 (proto:define-message typed-list ()
141 (string-car :type (or null string) :reader string-car)
142 (symbol-car :type (or null string) :reader symbol-car)
143 (integer-car :type (or null integer) :reader integer-car)
144 (float-car :type (or null single-float) :reader float-car)
145 (list-car :type (or null typed-list) :reader list-car)
146 (list-cdr :type (or null typed-list) :reader list-cdr)))
148 (defun string-car (x)
149 (and (stringp (car x)) (car x)))
151 (defun symbol-car (x)
152 (and (symbolp (car x)) (symbol-name (car x))))
154 (defun integer-car (x)
155 (and (integerp (car x)) (car x)))
158 (and (floatp (car x)) (car x)))
162 ((or string symbol integer float) nil)
166 (assert (listp (cdr x)) ())
169 (let ((list '("this" "is" "a" ("nested" "test"))))
170 (proto:serialize-object-to-bytes list 'typed-list)
171 (proto:print-text-format list 'typed-list)
172 (proto:print-text-format list 'typed-list :suppress-line-breaks t)
173 (let ((text (with-output-to-string (s)
174 (proto:print-text-format list 'typed-list :stream s))))
175 (with-input-from-string (s text)
176 (proto:parse-text-format 'typed-list :stream s))))
178 (let ((list '((1 one) (2 two) (3 three))))
179 (proto:serialize-object-to-bytes list 'typed-list)
180 (proto:print-text-format list 'typed-list)
181 (proto:print-text-format list 'typed-list :suppress-line-breaks t)
182 (let ((text (with-output-to-string (s)
183 (proto:print-text-format list 'typed-list :stream s))))
184 (with-input-from-string (s text)
185 (proto:parse-text-format 'typed-list :stream s))))
191 (proto:define-schema color-wheel
192 (:package color-wheel
194 :documentation "Color wheel example")
195 (proto:define-message color-wheel
196 (:conc-name color-wheel-)
198 (colors :type (proto:list-of color) :default ()))
199 (proto:define-message color
201 :documentation "A (named) color")
202 (name :type (or string null))
203 (r-value :type integer)
204 (g-value :type integer)
205 (b-value :type integer)
206 (proto:define-extension 1000 max))
207 (proto:define-extend color ()
208 ((opacity 1000) :type (or null integer)))
209 (proto:define-message get-color-request ()
210 (wheel :type color-wheel)
212 (proto:define-message add-color-request ()
213 (wheel :type color-wheel)
215 (proto:define-service color-wheel ()
216 (get-color (get-color-request => color)
217 :options (:deadline 1.0)
218 :documentation "Look up a color by name")
219 (add-color (add-color-request => color)
220 :options (:deadline 1.0)
221 :documentation "Add a new color to the wheel")))
223 (proto:write-schema *color-wheel*)
224 (proto:write-schema *color-wheel* :type :lisp)
226 (let* ((wheel (make-instance 'color-wheel :name "Colors"))
227 (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
228 (rqst1 (make-instance 'add-color-request :wheel wheel :color color1))
229 (color2 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
230 (rqst2 (make-instance 'add-color-request :wheel wheel :color color2)))
231 (setf (color-opacity color2) 50)
233 (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity))
234 (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color-request)))
236 (proto:print-text-format rqst1)
237 (proto:print-text-format (proto:deserialize-object 'add-color-request ser1))))
239 (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity))
240 (let ((ser2 (proto:serialize-object-to-bytes rqst2 'add-color-request)))
242 (proto:print-text-format rqst2)
243 (proto:print-text-format (proto:deserialize-object 'add-color-request ser2)))))
249 (proto:define-schema color-wheel1
250 (:package color-wheel
252 :documentation "Color wheel example, with nested message")
253 (proto:define-type-alias date ()
256 :serializer integer-to-date
257 :deserializer date-to-integer)
258 (proto:define-message color-wheel1 ()
259 (proto:define-message metadata1 ()
260 (author :type (or null string))
261 (revision :type (or null string))
262 (date :type (or null date)))
264 (colors :type (proto:list-of color1))
265 (metadata1 :type (or null metadata1)))
266 (proto:define-message color1 ()
267 (name :type (or null string))
268 (r-value :type integer)
269 (g-value :type integer)
270 (b-value :type integer))
271 (proto:define-message add-color1 ()
272 (wheel :type color-wheel1)
273 (color :type color1)))
275 (proto:define-schema color-wheel2
276 (:package color-wheel
278 :documentation "Color wheel example, with group")
279 (proto:define-type-alias date ()
282 :serializer integer-to-date
283 :deserializer date-to-integer)
284 (proto:define-message color-wheel2 ()
286 (colors :type (proto:list-of color2))
287 (proto:define-group metadata2
290 (author :type (or null string))
291 (revision :type (or null string))
292 (date :type (or null date))))
293 (proto:define-message color2 ()
294 (name :type (or null string))
295 (r-value :type integer)
296 (g-value :type integer)
297 (b-value :type integer))
298 (proto:define-message add-color2 ()
299 (wheel :type color-wheel2)
300 (color :type color2)))
302 (defun integer-to-date (date)
303 (with-output-to-string (s)
304 (quux:write-local-date (quux:get-local-time date) s :format :dd-mth-yyyy)))
306 (defun date-to-integer (string)
307 (quux:parse-local-date string))
309 (proto:write-schema *color-wheel1*)
310 (proto:write-schema *color-wheel2*)
312 (let* ((meta1 (make-instance 'metadata1 :revision "1.0" :date (date-to-integer "12-FEB-1958")))
313 (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata1 meta1))
314 (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
315 (rqst1 (make-instance 'add-color1 :wheel wheel1 :color color1))
316 (meta2 (make-instance 'metadata2 :revision "1.0" :date (date-to-integer "12-FEB-1958")))
317 (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata2 meta2))
318 (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
319 (rqst2 (make-instance 'add-color2 :wheel wheel2 :color color2)))
321 (format t "~2&Nested")
322 (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color1)))
324 (proto:print-text-format rqst1)
325 (proto:print-text-format (proto:deserialize-object 'add-color1 ser1))))
327 (format t "~2&Group")
328 (let ((ser2 (proto:serialize-object-to-bytes rqst2 'add-color2)))
330 (proto:print-text-format rqst2)
331 (proto:print-text-format (proto:deserialize-object 'add-color2 ser2)))))