examples.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Some examples; also for some for manual testing
  15
  16 #||
  17 ;; A pretty useful subset of air schedule objects
  18 (setq sched-schema (proto:generate-schema-for-classes
  19                     '(quux::zoned-time
  20                       sched::scheduled-flight
  21                       sched::flight-designator
  22                       sched::flight-key
  23                       sched::scheduled-segment
  24                       sched::segment-key
  25                       sched::subsegment-key
  26                       sched::scheduled-leg
  27                       sched::leg-key
  28                       sched::revision-entry)
  29                     :package :qres-sched
  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))
  34
  35 (proto:write-schema sched-schema)
  36 (proto:write-schema sched-schema :type :lisp)
  37 ||#
  38
  39
  40 #||
  41 ;; A pretty useful subset of geographic business data
  42 (defclass geodata ()
  43   ;; This one stores the data in lists
  44   ((countries :type (proto:list-of qres-core::country)
  45               :initform ()
  46               :initarg :countries)
  47    (regions :type (proto:list-of qres-core::region)
  48             :initform ()
  49             :initarg :regions)
  50    (cities :type (proto:list-of qres-core::city)
  51            :initform ()
  52            :initarg :cities)
  53    (airports :type (proto:list-of qres-core::airport)
  54              :initform ()
  55              :initarg :airports)))
  56
  57 (defclass geodata-v ()
  58   ;; This one stores the data in vectors
  59   ((countries :type (proto:vector-of qres-core::country)
  60               :initform #()
  61               :initarg :countries)
  62    (regions :type (proto:vector-of qres-core::region)
  63             :initform #()
  64             :initarg :regions)
  65    (cities :type (proto:vector-of qres-core::city)
  66            :initform #()
  67            :initarg :cities)
  68    (airports :type (proto:vector-of qres-core::airport)
  69              :initform #()
  70              :initarg :airports)))
  71
  72 (setq *geodata* (proto:generate-schema-for-classes
  73                  '(qres-core::country
  74                    qres-core::region
  75                    qres-core::region-key
  76                    qres-core::city
  77                    qres-core::airport
  78                    qres-core::timezone
  79                    qres-core::tz-variation
  80                    qres-core::currency
  81                    qres-core::country-currencies
  82                    qres-core::carrier
  83                    geodata geodata-v)
  84                  :install t))
  85
  86 (proto:write-schema *geodata*)
  87 (proto:write-schema *geodata* :type :lisp)
  88
  89 ;; Load the data
  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
  95                   :countries countries
  96                   :regions regions
  97                   :cities cities
  98                   :airports airports)
  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))))
 104
 105 (dolist (class '(qres-core::country
 106                  qres-core::region
 107                  qres-core::region-key
 108                  qres-core::city
 109                  qres-core::airport
 110                  qres-core::timezone
 111                  qres-core::tz-variation
 112                  qres-core::currency
 113                  qres-core::country-currencies
 114                  qres-core::carrier
 115                  geodata geodata-v))
 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))))
 120
 121 (time (progn (setq gser (proto:serialize-object-to-bytes geodata 'geodata)) nil))
 122 (time (proto:deserialize-object 'geodata gser))
 123
 124 (equalp gser (proto:serialize-object-to-bytes
 125               (proto:deserialize-object 'geodata gser) 'geodata))
 126
 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))
 129
 130 (equalp gser-v (proto:serialize-object-to-bytes
 131                 (proto:deserialize-object 'geodata-v gser-v) 'geodata-v))
 132
 133 (equalp gser gser-v)
 134 ||#
 135
 136
 137 #||
 138 ;; Lisp lists :-)
 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)))
 147
 148 (defun string-car (x)
 149   (and (stringp (car x)) (car x)))
 150
 151 (defun symbol-car (x)
 152   (and (symbolp (car x)) (symbol-name (car x))))
 153
 154 (defun integer-car (x)
 155   (and (integerp (car x)) (car x)))
 156
 157 (defun float-car (x)
 158   (and (floatp (car x)) (car x)))
 159
 160 (defun list-car (x)
 161   (etypecase (car x)
 162     ((or string symbol integer float) nil)
 163     (list (car x))))
 164
 165 (defun list-cdr (x)
 166   (assert (listp (cdr x)) ())
 167   (cdr x))
 168
 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))))
 177
 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))))
 186 ||#
 187
 188
 189 #||
 190 ;; Extension example
 191 (proto:define-schema color-wheel
 192     (:package color-wheel
 193      :optimize :speed
 194      :documentation "Color wheel example")
 195   (proto:define-message color-wheel
 196       (:conc-name color-wheel-)
 197     (name   :type string)
 198     (colors :type (proto:list-of color) :default ()))
 199   (proto:define-message color
 200       (:conc-name 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)
 211     (name  :type string))
 212   (proto:define-message add-color-request ()
 213     (wheel :type color-wheel)
 214     (color :type color))
 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")))
 222
 223 (proto:write-schema *color-wheel*)
 224 (proto:write-schema *color-wheel* :type :lisp)
 225
 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)
 232   (progn
 233     (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity))
 234     (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color-request)))
 235       (print ser1)
 236       (proto:print-text-format rqst1)
 237       (proto:print-text-format (proto:deserialize-object 'add-color-request ser1))))
 238   (progn
 239     (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity))
 240     (let ((ser2 (proto:serialize-object-to-bytes rqst2 'add-color-request)))
 241       (print ser2)
 242       (proto:print-text-format rqst2)
 243       (proto:print-text-format (proto:deserialize-object 'add-color-request ser2)))))
 244 ||#
 245
 246
 247 #||
 248 ;; Group example
 249 (proto:define-schema color-wheel1
 250     (:package color-wheel
 251      ;; :optimize :speed
 252      :documentation "Color wheel example, with nested message")
 253   (proto:define-type-alias date ()
 254     :lisp-type integer
 255     :proto-type string
 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)))
 263     (name :type string)
 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)))
 274
 275 (proto:define-schema color-wheel2
 276     (:package color-wheel
 277      ;; :optimize :speed
 278      :documentation "Color wheel example, with group")
 279   (proto:define-type-alias date ()
 280     :lisp-type integer
 281     :proto-type string
 282     :serializer integer-to-date
 283     :deserializer date-to-integer)
 284   (proto:define-message color-wheel2 ()
 285     (name :type string)
 286     (colors :type (proto:list-of color2))
 287     (proto:define-group metadata2
 288         (:index 3
 289          :arity :optional)
 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)))
 301
 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)))
 305
 306 (defun date-to-integer (string)
 307   (quux:parse-local-date string))
 308
 309 (proto:write-schema *color-wheel1*)
 310 (proto:write-schema *color-wheel2*)
 311
 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)))
 320   (progn
 321     (format t "~2&Nested")
 322     (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color1)))
 323       (print ser1)
 324       (proto:print-text-format rqst1)
 325       (proto:print-text-format (proto:deserialize-object 'add-color1 ser1))))
 326   (progn
 327     (format t "~2&Group")
 328     (let ((ser2 (proto:serialize-object-to-bytes rqst2 'add-color2)))
 329       (print ser2)
 330       (proto:print-text-format rqst2)
 331       (proto:print-text-format (proto:deserialize-object 'add-color2 ser2)))))
 332 ||#