examples.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Examples, for manual testing
  15
  16 ;;--- Turn these into a test suite
  17
  18 #||
  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))
  28
  29 (proto:write-protobuf cschema)
  30 (proto:write-protobuf cschema :type :lisp)
  31
  32 (proto:serialize-object-to-stream pnr 'qres-core::legacy-pnr :stream nil)
  33 ||#
  34
  35 #||
  36 (defclass geodata ()
  37   ((countries :type (list-of qres-core::country) :initform () :initarg :countries)
  38    (regions :type (list-of qres-core::region) :initform () :initarg :regions)
  39    (cities :type (list-of qres-core::city) :initform () :initarg :cities)
  40    (airports :type (list-of qres-core::airport) :initform () :initarg :airports)))
  41
  42 (setq bdschema (proto:generate-protobuf-schema-for-classes
  43                 '(qres-core::country
  44                   qres-core::region
  45                   qres-core::region-key
  46                   qres-core::city
  47                   qres-core::airport
  48                   qres-core::timezone
  49                   qres-core::tz-variation
  50                   qres-core::carrier
  51                   qres-core::currency
  52                   qres-core::country-currencies
  53                   geodata)))
  54
  55 (proto:write-protobuf bdschema)
  56 (proto:write-protobuf bdschema :type :lisp)
  57
  58 (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
  59        (regions   (loop for v being the hash-values of (qres-core::region-business-data) collect v))
  60        (cities    (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
  61        (airports  (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v))))
  62   (setq geodata (make-instance 'geodata
  63                   :countries countries
  64                   :regions regions
  65                   :cities cities
  66                   :airports airports)))
  67
  68 (dolist (class '(qres-core::country
  69                  qres-core::region
  70                  qres-core::region-key
  71                  qres-core::city
  72                  qres-core::airport
  73                  qres-core::timezone
  74                  qres-core::tz-variation
  75                  qres-core::carrier
  76                  qres-core::currency
  77                  qres-core::country-currencies
  78                  geodata))
  79   (let ((message (proto-impl:find-message bdschema class)))
  80     (eval (proto-impl:generate-object-size  message))
  81     (eval (proto-impl:generate-serializer   message))
  82     (eval (proto-impl:generate-deserializer message))))
  83
  84 (progn (setq gser (proto:serialize-object-to-stream geodata 'geodata :stream nil)) nil)
  85 (proto:deserialize-object 'geodata gser)
  86
  87 (equalp gser (proto:serialize-object-to-stream
  88               (proto:deserialize-object 'geodata gser)
  89               'geodata :stream nil))
  90 ||#
  91
  92 #||
  93 (setq pschema (proto:generate-protobuf-schema-for-classes
  94                '(proto:protobuf proto:protobuf-option
  95                  proto:protobuf-enum proto:protobuf-enum-value
  96                  proto:protobuf-message proto:protobuf-field proto:protobuf-extension
  97                  proto:protobuf-service proto:protobuf-rpc)))
  98
  99 (proto:write-protobuf pschema)
 100 (proto:write-protobuf pschema :type :lisp)
 101
 102 (progn (setq pser (proto:serialize-object-to-stream pschema 'proto:protobuf :stream nil)) nil)
 103 (describe (proto:deserialize-object 'proto:protobuf pser))
 104
 105 (proto:print-text-format pschema)
 106 (proto:print-text-format (proto:deserialize-object 'proto:protobuf pser))
 107
 108 (dolist (class '(proto:protobuf
 109                  proto:protobuf-option
 110                  proto:protobuf-enum
 111                  proto:protobuf-enum-value
 112                  proto:protobuf-message
 113                  proto:protobuf-field
 114                  proto:protobuf-extension
 115                  proto:protobuf-service
 116                  proto:protobuf-rpc))
 117   (let ((message (proto-impl:find-message pschema class)))
 118     (eval (proto-impl:generate-object-size  message))
 119     (eval (proto-impl:generate-serializer   message))
 120     (eval (proto-impl:generate-deserializer message))))
 121 ||#
 122
 123 #||
 124 (defclass proto-test1 ()
 125   ((intval :type (integer -2147483648 +2147483647)
 126            :initarg :intval)))
 127
 128 (defclass proto-test2 ()
 129   ((intval :type (or null (integer -2147483648 +2147483647))
 130            :initform nil
 131            :initarg :intval)
 132    (strval :type (or null string)
 133            :initform nil
 134            :initarg :strval)))
 135
 136 (defclass proto-test3 ()
 137   ((intval :type (or null (integer -2147483648 +2147483647))
 138            :initform nil
 139            :initarg :intval)
 140    (strval :type (or null string)
 141            :initform nil
 142            :initarg :strval)
 143    (recval :type (or null proto-test1)
 144            :initform nil
 145            :initarg :recval)))
 146
 147 (defclass proto-test4 ()
 148   ((intval :type (or null (integer -2147483648 +2147483647))
 149            :initform nil
 150            :initarg :intval)
 151    (strval :type (or null string)
 152            :initform nil
 153            :initarg :strval)
 154    (recval :type (or null proto-test2)
 155            :initform nil
 156            :initarg :recval)))
 157
 158 (defclass proto-test5 ()
 159   ((color   :type (member :red :green :blue)
 160             :initarg :color)
 161    (intvals :type (list-of integer)
 162             :initform ()
 163             :initarg :intvals)
 164    (strvals :type (list-of string)
 165             :initform ()
 166             :initarg :strvals)))
 167
 168 (defclass proto-test6 ()
 169   ((intvals :type (list-of integer)
 170             :initform ()
 171             :initarg :intvals)
 172    (strvals :type (list-of string)
 173             :initform ()
 174             :initarg :strvals)
 175    (recvals :type (list-of proto-test2)
 176             :initform ()
 177             :initarg :recvals)))
 178
 179 (setq tschema (proto:generate-protobuf-schema-for-classes
 180                '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6)))
 181
 182 (proto:write-protobuf tschema)
 183 (proto:write-protobuf tschema :type :lisp)
 184
 185 (dolist (class '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6))
 186   (let ((message (proto-impl:find-message tschema class)))
 187     (eval (proto-impl:generate-object-size  message))
 188     (eval (proto-impl:generate-serializer   message))
 189     (eval (proto-impl:generate-deserializer message))))
 190
 191 (setq test1  (make-instance 'proto-test1 :intval 150))
 192 (setq test2  (make-instance 'proto-test2 :strval "testing"))
 193 (setq test2b (make-instance 'proto-test2 :strval "1 2 3"))
 194 (setq test3  (make-instance 'proto-test3 :recval test1))
 195 (setq test4  (make-instance 'proto-test4 :recval test2))
 196 (setq test5  (make-instance 'proto-test5 :color :red
 197                                          :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
 198 (setq test6  (make-instance 'proto-test6 :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")
 199                                          :recvals (list test2 test2b)))
 200
 201 (setq tser1 (proto:serialize-object-to-stream test1 'proto-test1 :stream nil))
 202 (equalp tser1 #(#x08 #x96 #x01))
 203 (describe (proto:deserialize-object 'proto-test1 tser1))
 204
 205 (setq tser2 (proto:serialize-object-to-stream test2 'proto-test2 :stream nil))
 206 (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
 207 (describe (proto:deserialize-object 'proto-test2 tser2))
 208
 209 (setq tser3 (proto:serialize-object-to-stream test3 'proto-test3 :stream nil))
 210 (equalp tser3 #(#x1A #x03 #x08 #x96 #x01))
 211 (describe (proto:deserialize-object 'proto-test3 tser3))
 212 (describe (slot-value (proto:deserialize-object 'proto-test3 tser3) 'recval))
 213
 214 (setq tser4 (proto:serialize-object-to-stream test4 'proto-test4 :stream nil))
 215 (equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
 216 (describe (proto:deserialize-object 'proto-test4 tser4))
 217 (describe (slot-value (proto:deserialize-object 'proto-test4 tser4) 'recval))
 218
 219 (setq tser5 (proto:serialize-object-to-stream test5 'proto-test5 :stream nil))
 220 (equalp tser5 #(#x08 #x01
 221                 #x10 #x04 #x02 #x03 #x05 #x07
 222                 #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))
 223 (describe (proto:deserialize-object 'proto-test5 tser5))
 224
 225 (setq tser6 (proto:serialize-object-to-stream test6 'proto-test6 :stream nil))
 226 (equalp tser6 #(#x08 #x04 #x02 #x03 #x05 #x07 #x12 #x03 #x74 #x77 #x6F #x12 #x05 #x74 #x68 #x72 #x65 #x65 #x12 #x04 #x66 #x69 #x76 #x65 #x12 #x05 #x73 #x65 #x76 #x65 #x6E #x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67 #x1A #x07 #x12 #x05 #x31 #x20 #x32 #x20 #x33))
 227 (describe (proto:deserialize-object 'proto-test6 tser6))
 228 (describe (slot-value (proto:deserialize-object 'proto-test6 tser6) 'recvals))
 229
 230
 231 (equalp (mapcar #'proto-impl:zig-zag-encode32
 232                 '(0 -1 1 -2 2 -2147483648 2147483647))
 233         '(0 1 2 3 4 4294967295 4294967294))
 234 (equalp (mapcar #'proto-impl:zig-zag-encode64
 235                 '(0 -1 1 -2 2 -2147483648 2147483647 -1152921504606846976 1152921504606846975))
 236         '(0 1 2 3 4 4294967295 4294967294 2305843009213693951 2305843009213693950))
 237
 238 (proto:print-text-format test1)
 239 (proto:print-text-format (proto:deserialize-object 'proto-test1 tser1))
 240
 241 (proto:print-text-format test2)
 242 (proto:print-text-format (proto:deserialize-object 'proto-test2 tser2))
 243
 244 (proto:print-text-format test3)
 245 (proto:print-text-format (proto:deserialize-object 'proto-test3 tser3))
 246
 247 (proto:print-text-format test4)
 248 (proto:print-text-format (proto:deserialize-object 'proto-test4 tser4))
 249
 250 (proto:print-text-format test5)
 251 (proto:print-text-format (proto:deserialize-object 'proto-test5 tser5))
 252
 253 (proto:print-text-format test6)
 254 (proto:print-text-format (proto:deserialize-object 'proto-test6 tser6))
 255 ||#
 256
 257 #||
 258 (let* ((enums (list (make-instance 'proto:protobuf-enum
 259                       :name "ColorName"
 260                       :values (list (make-instance 'proto:protobuf-enum-value
 261                                       :name "RED"
 262                                       :index 1
 263                                       :value :red)
 264                                     (make-instance 'proto:protobuf-enum-value
 265                                       :name "GREEN"
 266                                       :index 2
 267                                       :value :green)
 268                                     (make-instance 'proto:protobuf-enum-value
 269                                       :name "BLUE"
 270                                       :index 3
 271                                       :value :blue)))))
 272        (msgs  (list (make-instance 'proto:protobuf-message
 273                       :name "Color"
 274                       :enums (list (make-instance 'proto:protobuf-enum
 275                                       :name "ContrastName"
 276                                       :values (list (make-instance 'proto:protobuf-enum-value
 277                                                       :name "LOW"
 278                                                       :index 1
 279                                                       :value :high)
 280                                                     (make-instance 'proto:protobuf-enum-value
 281                                                       :name "HIGH"
 282                                                       :index 100
 283                                                       :value :low))))
 284                       :fields (list (make-instance 'proto:protobuf-field
 285                                       :name "color"
 286                                       :type "ColorName"
 287                                       :required :required
 288                                       :index 1)
 289                                     (make-instance 'proto:protobuf-field
 290                                       :name "contrast"
 291                                       :type "ContrastName"
 292                                       :required :optional
 293                                       :index 2
 294                                       :default "LOW")))))
 295        (rpcs  (list (make-instance 'proto:protobuf-rpc
 296                       :name "GetColor"
 297                       :input-name "string"
 298                       :output-name "Color")
 299                     (make-instance 'proto:protobuf-rpc
 300                       :name "SetColor"
 301                       :input-name "Color"
 302                       :output-name "Color"
 303                       :options (list (make-instance 'proto:protobuf-option
 304                                        :name "deadline" :value "1.0")))))
 305        (svcs  (list (make-instance 'proto:protobuf-service
 306                       :name "ColorWheel"
 307                       :rpcs rpcs)))
 308        (proto (make-instance 'proto:protobuf
 309                 :package "ita.color"
 310                 :imports '("descriptor.proto")
 311                 :enums enums
 312                 :messages msgs
 313                 :services svcs)))
 314   ;; The output should be example the same as the output of 'write-protobuf' below
 315   (proto:write-protobuf proto))
 316 ||#
 317
 318 #||
 319 (proto:define-proto color-wheel
 320     (:package ita.color
 321      :import "descriptor.proto"
 322      :documentation "Color wheel example")
 323   (proto:define-enum color-name
 324       (:documentation "A color name")
 325     red
 326     green
 327     blue)
 328   (proto:define-message color
 329       (:conc-name color-
 330        :documentation "Color and contrast")
 331     (proto:define-enum contrast-name
 332         (:documentation "A contrast name")
 333       (low    1)
 334       (high 100))
 335     (color    :type color-name)
 336     (contrast :type (or null contrast-name) :default :low))
 337   (proto:define-service color-wheel
 338       (:documentation "Get and set colors")
 339     (get-color (string color))
 340     (set-color (color color)
 341                :options ("deadline" "1.0"))))
 342
 343 => (PROGN
 344      (DEFTYPE COLOR-NAME () '(MEMBER :RED :GREEN :BLUE))
 345      (DEFTYPE CONTRAST-NAME () '(MEMBER :LOW :HIGH))
 346      (DEFCLASS COLOR ()
 347        ((COLOR :TYPE COLOR-NAME :ACCESSOR COLOR-COLOR :INITARG :COLOR)
 348         (CONTRAST :TYPE (OR NULL CONTRAST-NAME) :ACCESSOR COLOR-CONTRAST :INITARG :CONTRAST :INITFORM :LOW)))
 349      (DEFVAR *COLOR-WHEEL*
 350        (MAKE-INSTANCE 'PROTOBUF
 351          :NAME "ColorWheel"
 352          :CLASS 'COLOR-WHEEL
 353          :PACKAGE "ita.color"
 354          :IMPORTS '("descriptor.proto")
 355          :SYNTAX "proto2"
 356          :OPTIONS ()
 357          :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
 358                         :NAME "ColorName"
 359                         :CLASS 'COLOR-NAME
 360                         :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 361                                         :NAME "RED" :INDEX 1 :VALUE :RED)
 362                                       (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 363                                         :NAME "GREEN" :INDEX 2 :VALUE :GREEN)
 364                                       (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 365                                         :NAME "BLUE" :INDEX 3 :VALUE :BLUE))))
 366          :MESSAGES (LIST (MAKE-INSTANCE 'PROTOBUF-MESSAGE
 367                            :NAME "Color"
 368                            :CLASS 'COLOR
 369                            :CONC-NAME "COLOR-"
 370                            :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
 371                                           :NAME "ContrastName"
 372                                           :CLASS 'CONTRAST-NAME
 373                                           :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 374                                                           :NAME "LOW" :INDEX 1 :VALUE :LOW)
 375                                                         (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
 376                                                           :NAME "HIGH" :INDEX 100 :VALUE :HIGH))))
 377                            :MESSAGES (LIST)
 378                            :FIELDS (LIST (MAKE-INSTANCE 'PROTOBUF-FIELD
 379                                            :NAME "color"
 380                                            :TYPE "ColorName"
 381                                            :CLASS 'COLOR-NAME
 382                                            :REQUIRED :REQUIRED
 383                                            :INDEX 1
 384                                            :VALUE 'COLOR
 385                                            :DEFAULT NIL
 386                                            :PACKED NIL)
 387                                          (MAKE-INSTANCE 'PROTOBUF-FIELD
 388                                            :NAME "contrast"
 389                                            :TYPE "ContrastName"
 390                                            :CLASS 'CONTRAST-NAME
 391                                            :REQUIRED :OPTIONAL
 392                                            :INDEX 2
 393                                            :VALUE 'CONTRAST
 394                                            :DEFAULT "LOW"
 395                                            :PACKED NIL))))
 396          :SERVICES (LIST (MAKE-INSTANCE 'PROTOBUF-SERVICE
 397                            :NAME "ColorWheel"
 398                            :CLASS 'COLOR-WHEEL
 399                            :RPCS (LIST (MAKE-INSTANCE 'PROTOBUF-RPC
 400                                          :NAME "GetColor"
 401                                          :CLASS 'GET-COLOR
 402                                          :INPUT-NAME "string"
 403                                          :OUTPUT-NAME "Color"
 404                                          :OPTIONS (LIST))
 405                                        (MAKE-INSTANCE 'PROTOBUF-RPC
 406                                          :NAME "SetColor"
 407                                          :CLASS 'SET-COLOR
 408                                          :INPUT-NAME "Color"
 409                                          :OUTPUT-NAME "Color"
 410                                          :OPTIONS (LIST (MAKE-INSTANCE 'PROTOBUF-OPTION
 411                                                           :NAME "deadline" :VALUE "1.0")))))))))
 412
 413 ;; The output should be example the same as the output of 'write-protobuf' above
 414 (proto:write-protobuf *color-wheel*)
 415
 416 ;; How does the Lisp version look?
 417 (proto:write-protobuf *color-wheel* :type :lisp)
 418
 419 (setq clr (make-instance 'color :color :red))
 420 (setq cser (proto:serialize-object-to-stream clr 'color :stream nil))
 421 (proto:print-text-format clr)
 422 (proto:print-text-format (proto:deserialize-object 'color cser))
 423 ||#
 424
 425 #||
 426 (let ((ps "package ita.color;
 427
 428 import \"descriptor.proto\";
 429
 430 enum ColorName {
 431   RED = 1;
 432   GREEN = 2;
 433   BLUE = 3;
 434 }
 435
 436 message Color {
 437   enum ContrastName {
 438     LOW = 1;
 439     HIGH = 100;
 440   }
 441   required ColorName color = 1;
 442   optional ContrastName contrast = 2 [default = LOW];
 443 }
 444
 445 service ColorWheel {
 446   rpc GetColor (string) returns (Color);
 447   rpc SetColor (Color) returns (Color) {
 448     option deadline = \"1.0\";
 449   }
 450 }"))
 451   (with-input-from-string (s ps)
 452     (setq ppp (proto:parse-protobuf-from-stream s))))
 453
 454 (proto:write-protobuf ppp)
 455 (proto:write-protobuf ppp :type :lisp)
 456 ||#
 457
 458 #||
 459 (proto:define-proto typed-list ()
 460   (proto:define-message typed-list (:alias-for list)
 461     (string-car  :type (or null string)  :reader string-car)
 462     (symbol-car  :type (or null string)  :reader symbol-car)
 463     (integer-car :type (or null integer) :reader integer-car)
 464     (float-car   :type (or null single-float) :reader float-car)
 465     (list-car  :type (or null typed-list) :reader list-car)
 466     (cdr       :type (or null typed-list) :reader list-cdr)))
 467
 468 (defun string-car (x)
 469   (and (stringp (car x)) (car x)))
 470
 471 (defun symbol-car (x)
 472   (and (symbolp (car x)) (symbol-name (car x))))
 473
 474 (defun integer-car (x)
 475   (and (integerp (car x)) (car x)))
 476
 477 (defun float-car (x)
 478   (and (floatp (car x)) (car x)))
 479
 480 (defun list-car (x)
 481   (etypecase (car x)
 482     ((or string symbol integer float) nil)
 483     (list (car x))))
 484
 485 (defun list-cdr (x)
 486   (assert (listp (cdr x)) ())
 487   (cdr x))
 488
 489 (proto:serialize-object-to-stream '("this" "is" "a" ("nested" "test")) 'typed-list :stream nil)
 490 (proto:print-text-format '("this" "is" "a" ("nested" "test")) 'typed-list)
 491 (proto:print-text-format '("this" "is" "a" ("nested" "test")) 'typed-list :suppress-line-breaks t)
 492
 493 (proto:serialize-object-to-stream '((1 one) (2 two) (3 three)) 'typed-list :stream nil)
 494 (proto:print-text-format '((1 one) (2 two) (3 three)) 'typed-list)
 495 (proto:print-text-format '((1 one) (2 two) (3 three)) 'typed-list :suppress-line-breaks t)
 496 ||#