X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=examples.lisp;h=1ff8d53d117f5b303680a1a546f989b698ebb4e1;hb=ae85cfed94d4b1d69529ceaac32a7583198ff485;hp=eceb9ac79842d183a812010cbf5f4535a8bc7f17;hpb=7e99c5a1ca8a4ee09eec2ea63e42fb2c9d98c667;p=cl-protobufs.git diff --git a/examples.lisp b/examples.lisp index eceb9ac..1ff8d53 100644 --- a/examples.lisp +++ b/examples.lisp @@ -1,8 +1,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; -;;; 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 ;;; ;;; ;;; @@ -11,264 +11,322 @@ (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)) + +(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 test2 tschema) -(proto:print-text-format test3 tschema) -(proto:print-text-format test4 tschema) -(proto:print-text-format test5 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))))) ||#