tests/serialization-tests.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-TEST")
  12
  13
  14 ;;; Basic serialization unit tests
  15
  16 (eval-when (:compile-toplevel :load-toplevel :execute)
  17
  18 (deftype user-integer () 'integer)
  19
  20 (defclass basic-test1 ()
  21   ((intval :type (signed-byte 32)
  22            :initarg :intval)))
  23
  24 (defclass basic-test2 ()
  25   ((intval :type (or null (signed-byte 32))
  26            :initform nil
  27            :initarg :intval)
  28    (strval :type (or null string)
  29            :initform nil
  30            :initarg :strval)))
  31
  32 (defclass basic-test3 ()
  33   ((intval :type (or null (signed-byte 32))
  34            :initform nil
  35            :initarg :intval)
  36    (strval :type (or null string)
  37            :initform nil
  38            :initarg :strval)
  39    (recval :type (or null basic-test1)
  40            :initform nil
  41            :initarg :recval)))
  42
  43 (defclass basic-test4 ()
  44   ((intval :type (or null (signed-byte 32))
  45            :initform nil
  46            :initarg :intval)
  47    (strval :type (or null string)
  48            :initform nil
  49            :initarg :strval)
  50    (recval :type (or null basic-test2)
  51            :initform nil
  52            :initarg :recval)))
  53
  54 (defclass basic-test5 ()
  55   ((color   :type (member :red :green :blue)
  56             :initarg :color)
  57    (intvals :type (proto:list-of integer)
  58             :initform ()
  59             :initarg :intvals)
  60    (strvals :type (proto:list-of string)
  61             :initform ()
  62             :initarg :strvals)))
  63
  64 (defclass basic-test6 ()
  65   ((intvals :type (proto:list-of integer)
  66             :initform ()
  67             :initarg :intvals)
  68    (strvals :type (proto:list-of string)
  69             :initform ()
  70             :initarg :strvals)
  71    (recvals :type (proto:list-of basic-test2)
  72             :initform ()
  73             :initarg :recvals)))
  74
  75 (defclass basic-test7 ()
  76   ((intval :type (or null user-integer)
  77            :initform ()
  78            :initarg :intval)))
  79
  80 )       ;eval-when
  81
  82 (defvar *basic-test-schema*
  83   (generate-schema-for-classes
  84     '(basic-test1 basic-test2 basic-test3 basic-test4 basic-test5 basic-test6 basic-test7)
  85     :install t))
  86
  87 (define-test basic-serialization ()
  88   (let* ((test1  (make-instance 'basic-test1 :intval 150))
  89          (test1b (make-instance 'basic-test1 :intval -150))
  90          (test2  (make-instance 'basic-test2 :strval "testing"))
  91          (test2b (make-instance 'basic-test2 :strval "1 2 3"))
  92          (test3  (make-instance 'basic-test3 :recval test1))
  93          (test4  (make-instance 'basic-test4 :recval test2))
  94          (test5  (make-instance 'basic-test5
  95                    :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
  96          (test6  (make-instance 'basic-test6
  97                    :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
  98          (test7  (make-instance 'basic-test7 :intval 150))
  99 )
 100     (let ((tser1  (serialize-object-to-bytes test1 'basic-test1))
 101           (tser1b (serialize-object-to-bytes test1b 'basic-test1))
 102           (tser2  (serialize-object-to-bytes test2 'basic-test2))
 103           (tser3  (serialize-object-to-bytes test3 'basic-test3))
 104           (tser4  (serialize-object-to-bytes test4 'basic-test4))
 105           (tser5  (serialize-object-to-bytes test5 'basic-test5))
 106           (tser6  (serialize-object-to-bytes test6 'basic-test6))
 107           (tser7  (serialize-object-to-bytes test7 'basic-test7)))
 108       (assert-true (equalp tser1 #(#x08 #x96 #x01)))
 109       (assert-true (equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F)))
 110       (assert-true (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
 111       (assert-true (equalp tser3 #(#x1A #x03 #x08 #x96 #x01)))
 112       (assert-true (equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
 113       (assert-true (equalp tser5 #(#x08 #x00
 114                                    #x10 #x04 #x02 #x03 #x05 #x07
 115                                    #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)))
 116       (assert-true (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)))
 117       (assert-true (equalp tser7 #(#x08 #x96 #x01)))
 118       (macrolet ((slots-equalp (obj1 obj2 &rest slots)
 119                    (proto-impl::with-gensyms (vobj1 vobj2)
 120                      (proto-impl::with-collectors ((forms collect-form))
 121                        (dolist (slot slots)
 122                          (collect-form `(assert-true
 123                                          (equalp (slot-value ,vobj1 ',slot) (slot-value ,vobj2 ',slot)))))
 124                        `(let ((,vobj1 ,obj1)
 125                               (,vobj2 ,obj2))
 126                           ,@forms)))))
 127         (slots-equalp test1 (deserialize-object 'basic-test1 tser1)
 128                       intval)
 129         (slots-equalp test1b (deserialize-object 'basic-test1 tser1b)
 130                       intval)
 131         (slots-equalp test2 (deserialize-object 'basic-test2 tser2)
 132                       intval strval)
 133         (slots-equalp test3 (deserialize-object 'basic-test3 tser3)
 134                       intval strval)
 135         (slots-equalp (slot-value test3 'recval)
 136                       (slot-value (deserialize-object 'basic-test3 tser3) 'recval)
 137                       intval)
 138         (slots-equalp test4 (deserialize-object 'basic-test4 tser4)
 139                       intval strval)
 140         (slots-equalp (slot-value test4 'recval)
 141                       (slot-value (deserialize-object 'basic-test4 tser4) 'recval)
 142                       intval strval)
 143         (slots-equalp test5 (deserialize-object 'basic-test5 tser5)
 144                       color intvals strvals)
 145         (slots-equalp test6 (deserialize-object 'basic-test6 tser6)
 146                       intvals strvals)
 147         (slots-equalp (first (slot-value test6 'recvals))
 148                       (first (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
 149                       strval)
 150         (slots-equalp (second (slot-value test6 'recvals))
 151                       (second (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
 152                       strval)
 153         (slots-equalp test7 (deserialize-object 'basic-test7 tser7)
 154                       intval)))))
 155
 156 (define-test basic-optimized-serialization ()
 157   (dolist (class '(basic-test1 basic-test2 basic-test3 basic-test4 basic-test5 basic-test6))
 158     (let ((message (find-message *basic-test-schema* class)))
 159       (handler-bind ((style-warning #'muffle-warning))
 160         (eval (generate-object-size  message))
 161         (eval (generate-serializer   message))
 162         (eval (generate-deserializer message)))))
 163   (let* ((test1  (make-instance 'basic-test1 :intval 150))
 164          (test1b (make-instance 'basic-test1 :intval -150))
 165          (test2  (make-instance 'basic-test2 :strval "testing"))
 166          (test2b (make-instance 'basic-test2 :strval "1 2 3"))
 167          (test3  (make-instance 'basic-test3 :recval test1))
 168          (test4  (make-instance 'basic-test4 :recval test2))
 169          (test5  (make-instance 'basic-test5
 170                    :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
 171          (test6  (make-instance 'basic-test6
 172                    :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
 173          (test7  (make-instance 'basic-test7 :intval 150)))
 174     (let ((tser1  (serialize-object-to-bytes test1 'basic-test1))
 175           (tser1b (serialize-object-to-bytes test1b 'basic-test1))
 176           (tser2  (serialize-object-to-bytes test2 'basic-test2))
 177           (tser3  (serialize-object-to-bytes test3 'basic-test3))
 178           (tser4  (serialize-object-to-bytes test4 'basic-test4))
 179           (tser5  (serialize-object-to-bytes test5 'basic-test5))
 180           (tser6  (serialize-object-to-bytes test6 'basic-test6))
 181           (tser7  (serialize-object-to-bytes test7 'basic-test7)))
 182       (assert-true (equalp tser1 #(#x08 #x96 #x01)))
 183       (assert-true (equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F)))
 184       (assert-true (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
 185       (assert-true (equalp tser3 #(#x1A #x03 #x08 #x96 #x01)))
 186       (assert-true (equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
 187       (assert-true (equalp tser5 #(#x08 #x00
 188                                    #x10 #x04 #x02 #x03 #x05 #x07
 189                                    #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)))
 190       (assert-true (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)))
 191       (assert-true (equalp tser7 #(#x08 #x96 #x01)))
 192       (macrolet ((slots-equalp (obj1 obj2 &rest slots)
 193                    (proto-impl::with-gensyms (vobj1 vobj2)
 194                      (proto-impl::with-collectors ((forms collect-form))
 195                        (dolist (slot slots)
 196                          (collect-form `(assert-true
 197                                          (equalp (slot-value ,vobj1 ',slot) (slot-value ,vobj2 ',slot)))))
 198                        `(let ((,vobj1 ,obj1)
 199                               (,vobj2 ,obj2))
 200                           ,@forms)))))
 201         (slots-equalp test1 (deserialize-object 'basic-test1 tser1)
 202                       intval)
 203         (slots-equalp test1b (deserialize-object 'basic-test1 tser1b)
 204                       intval)
 205         (slots-equalp test2 (deserialize-object 'basic-test2 tser2)
 206                       intval strval)
 207         (slots-equalp test3 (deserialize-object 'basic-test3 tser3)
 208                       intval strval)
 209         (slots-equalp (slot-value test3 'recval)
 210                       (slot-value (deserialize-object 'basic-test3 tser3) 'recval)
 211                       intval)
 212         (slots-equalp test4 (deserialize-object 'basic-test4 tser4)
 213                       intval strval)
 214         (slots-equalp (slot-value test4 'recval)
 215                       (slot-value (deserialize-object 'basic-test4 tser4) 'recval)
 216                       intval strval)
 217         (slots-equalp test5 (deserialize-object 'basic-test5 tser5)
 218                       color intvals strvals)
 219         (slots-equalp test6 (deserialize-object 'basic-test6 tser6)
 220                       intvals strvals)
 221         (slots-equalp (first (slot-value test6 'recvals))
 222                       (first (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
 223                       strval)
 224         (slots-equalp (second (slot-value test6 'recvals))
 225                       (second (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
 226                       strval)
 227         (slots-equalp test7 (deserialize-object 'basic-test7 tser7)
 228                       intval)))))
 229
 230 (define-test text-serialization ()
 231   (let* ((test1  (make-instance 'basic-test1 :intval 150))
 232          (test1b (make-instance 'basic-test1 :intval -150))
 233          (test2  (make-instance 'basic-test2 :strval "testing"))
 234          (test2b (make-instance 'basic-test2 :strval "1 2 3"))
 235          (test3  (make-instance 'basic-test3 :recval test1))
 236          (test4  (make-instance 'basic-test4 :recval test2))
 237          (test5  (make-instance 'basic-test5
 238                    :color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
 239          (test6  (make-instance 'basic-test6
 240                    :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
 241          (test7  (make-instance 'basic-test7 :intval 150)))
 242     (let ((tser1  (serialize-object-to-bytes test1 'basic-test1))
 243           (tser1b (serialize-object-to-bytes test1b 'basic-test1))
 244           (tser2  (serialize-object-to-bytes test2 'basic-test2))
 245           (tser3  (serialize-object-to-bytes test3 'basic-test3))
 246           (tser4  (serialize-object-to-bytes test4 'basic-test4))
 247           (tser5  (serialize-object-to-bytes test5 'basic-test5))
 248           (tser6  (serialize-object-to-bytes test6 'basic-test6))
 249           (tser7  (serialize-object-to-bytes test7 'basic-test7)))
 250       (macrolet ((slots-equalp (obj1 obj2 &rest slots)
 251                    (proto-impl::with-gensyms (vobj1 vobj2)
 252                      (proto-impl::with-collectors ((forms collect-form))
 253                        (dolist (slot slots)
 254                          (collect-form `(assert-true
 255                                          (equalp (slot-value ,vobj1 ',slot) (slot-value ,vobj2 ',slot)))))
 256                        `(let ((,vobj1 ,obj1)
 257                               (,vobj2 ,obj2))
 258                           ,@forms)))))
 259         (let ((text (with-output-to-string (s)
 260                       (print-text-format test1 'basic-test1 :stream s))))
 261           (assert-true (string= text (with-output-to-string (s)
 262                                        (print-text-format
 263                                          (deserialize-object 'basic-test1 tser1) 'basic-test1 :stream s))))
 264           (slots-equalp test1 (with-input-from-string (s text)
 265                                 (parse-text-format 'basic-test1 :stream s))
 266                         intval))
 267         (let ((text (with-output-to-string (s)
 268                       (print-text-format test1b 'basic-test1 :stream s))))
 269           (assert-true (string= text (with-output-to-string (s)
 270                                        (print-text-format
 271                                          (deserialize-object 'basic-test1 tser1b) 'basic-test1 :stream s))))
 272           (slots-equalp test1b (with-input-from-string (s text)
 273                                  (parse-text-format 'basic-test1 :stream s))
 274                         intval))
 275         (let ((text (with-output-to-string (s)
 276                       (print-text-format test2 'basic-test2 :stream s))))
 277           (assert-true (string= text (with-output-to-string (s)
 278                                        (print-text-format
 279                                          (deserialize-object 'basic-test2 tser2) 'basic-test2 :stream s))))
 280           (slots-equalp test2 (with-input-from-string (s text)
 281                                 (parse-text-format 'basic-test2 :stream s))
 282                         intval strval))
 283         (let ((text (with-output-to-string (s)
 284                       (print-text-format test3 'basic-test3 :stream s))))
 285           (assert-true (string= text (with-output-to-string (s)
 286                                        (print-text-format
 287                                          (deserialize-object 'basic-test3 tser3) 'basic-test3 :stream s))))
 288           (slots-equalp test3 (with-input-from-string (s text)
 289                                 (parse-text-format 'basic-test3 :stream s))
 290                         intval strval)
 291           (slots-equalp (slot-value test3 'recval)
 292                         (slot-value (with-input-from-string (s text)
 293                                       (parse-text-format 'basic-test3 :stream s)) 'recval)
 294                         intval))
 295         (let ((text (with-output-to-string (s)
 296                       (print-text-format test4 'basic-test4 :stream s))))
 297           (assert-true (string= text (with-output-to-string (s)
 298                                        (print-text-format
 299                                          (deserialize-object 'basic-test4 tser4) 'basic-test4 :stream s))))
 300           (slots-equalp test4 (with-input-from-string (s text)
 301                                 (parse-text-format 'basic-test4 :stream s))
 302                         intval strval)
 303           (slots-equalp (slot-value test4 'recval)
 304                         (slot-value (with-input-from-string (s text)
 305                                       (parse-text-format 'basic-test4 :stream s)) 'recval)
 306                         intval strval))
 307         (let ((text (with-output-to-string (s)
 308                       (print-text-format test5 'basic-test5 :stream s))))
 309           (assert-true (string= text (with-output-to-string (s)
 310                                        (print-text-format
 311                                          (deserialize-object 'basic-test5 tser5) 'basic-test5 :stream s))))
 312           (slots-equalp test5 (with-input-from-string (s text)
 313                                 (parse-text-format 'basic-test5 :stream s))
 314                         color intvals strvals))
 315         (let ((text (with-output-to-string (s)
 316                       (print-text-format test6 'basic-test6 :stream s))))
 317           (assert-true (string= text (with-output-to-string (s)
 318                                        (print-text-format
 319                                          (deserialize-object 'basic-test6 tser6) 'basic-test6 :stream s))))
 320           (slots-equalp test6 (with-input-from-string (s text)
 321                                 (parse-text-format 'basic-test6 :stream s))
 322                         intvals strvals)
 323           (slots-equalp (first (slot-value test6 'recvals))
 324                         (first (slot-value
 325                                  (with-input-from-string (s text)
 326                                    (parse-text-format 'basic-test6 :stream s)) 'recvals))
 327                         strval)
 328           (slots-equalp (second (slot-value test6 'recvals))
 329                         (second (slot-value
 330                                   (with-input-from-string (s text)
 331                                     (parse-text-format 'basic-test6 :stream s)) 'recvals))
 332                         strval))
 333         (let ((text (with-output-to-string (s)
 334                       (print-text-format test7 'basic-test7 :stream s))))
 335           (assert-true (string= text (with-output-to-string (s)
 336                                        (print-text-format
 337                                          (deserialize-object 'basic-test7 tser7) 'basic-test7 :stream s))))
 338           (slots-equalp test7 (with-input-from-string (s text)
 339                                 (parse-text-format 'basic-test7 :stream s))
 340                         intval))))))
 341
 342
 343 (proto:define-schema integrity-test
 344     (:package proto_test)
 345   (proto:define-message inner ()
 346     (i :type (or null integer)))
 347   (proto:define-message outer ()
 348     (inner :type (proto:list-of inner))
 349     (simple :type (or null inner))
 350     (i :type (or null integer))))
 351
 352 (define-test serialization-integrity ()
 353   (flet ((do-test (message)
 354            (let* ((type (type-of message))
 355                   (buf (proto:serialize-object-to-bytes message type))
 356                   (new (proto:deserialize-object type buf))
 357                   (newbuf (proto:serialize-object-to-bytes new type)))
 358              (assert-true (equalp (length buf) (length newbuf)))
 359              (assert-true (equalp buf newbuf))
 360              (assert-true (string= (with-output-to-string (s)
 361                                      (proto:print-text-format message nil :stream s))
 362                                    (with-output-to-string (s)
 363                                      (proto:print-text-format new nil :stream s)))))))
 364     (do-test (make-instance 'outer :i 4))
 365     (do-test (make-instance 'outer :i -4))
 366     (do-test (make-instance 'outer
 367                :inner (mapcar #'(lambda (i) (make-instance 'inner :i i)) '(1 2 3))))
 368     (do-test (make-instance 'outer
 369                :inner (mapcar #'(lambda (i) (make-instance 'inner :i i)) '(-1 -2 -3))))
 370     (do-test (make-instance 'outer
 371                :simple (make-instance 'inner :i 4)))
 372     (do-test (make-instance 'outer
 373                :simple (make-instance 'inner :i -4)))))
 374
 375
 376 #+qres (progn
 377
 378 (eval-when (:compile-toplevel :load-toplevel :execute)
 379
 380 (defclass geodata ()
 381   ((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries)
 382    (regions :type (proto:list-of qres-core::region) :initform () :initarg :regions)
 383    (cities :type (proto:list-of qres-core::city) :initform () :initarg :cities)
 384    (airports :type (proto:list-of qres-core::airport) :initform () :initarg :airports)))
 385
 386 )       ;eval-when
 387
 388 (defvar *geodata-schema*
 389   (proto:generate-schema-for-classes
 390    '(qres-core::country qres-core::region qres-core::region-key
 391      qres-core::city qres-core::airport
 392      qres-core::timezone qres-core::tz-variation
 393      qres-core::currency qres-core::country-currencies
 394      qres-core::carrier
 395      geodata)
 396    :install t))
 397
 398 (define-test geodata-serialization ()
 399   (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
 400          (regions   (loop for v being the hash-values of (qres-core::region-business-data) collect v))
 401          (cities    (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
 402          (airports  (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v)))
 403          (geodata (make-instance 'geodata
 404                     :countries countries
 405                     :regions regions
 406                     :cities cities
 407                     :airports airports)))
 408     (let ((gser (proto:serialize-object-to-bytes geodata 'geodata)))
 409       (assert-true (equalp gser (proto:serialize-object-to-bytes
 410                                  (proto:deserialize-object 'geodata gser) 'geodata))))))
 411
 412 (define-test geodata-optimized-serialization ()
 413   (dolist (class '(qres-core::country qres-core::region qres-core::region-key
 414                    qres-core::city qres-core::airport
 415                    qres-core::timezone qres-core::tz-variation
 416                    qres-core::currency qres-core::country-currencies
 417                    qres-core::carrier
 418                    geodata))
 419     (let ((message (find-message *geodata-schema* class)))
 420       (eval (generate-object-size  message))
 421       (eval (generate-serializer   message))
 422       (eval (generate-deserializer message))))
 423   (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
 424          (regions   (loop for v being the hash-values of (qres-core::region-business-data) collect v))
 425          (cities    (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
 426          (airports  (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v)))
 427          (geodata (make-instance 'geodata
 428                     :countries countries
 429                     :regions regions
 430                     :cities cities
 431                     :airports airports)))
 432     (let ((gser (proto:serialize-object-to-bytes geodata 'geodata)))
 433       (assert-true (equalp gser (proto:serialize-object-to-bytes
 434                                   (proto:deserialize-object 'geodata gser) 'geodata))))))
 435
 436 )       ;#+qres
 437
 438
 439 ;; Extension example
 440 (proto:define-schema automobile
 441     (:package proto_test
 442      :optimize :speed)
 443   (proto:define-enum auto-status ()
 444     new
 445     used)
 446   (proto:define-enum paint-type ()
 447     normal
 448     metallic)
 449   (proto:define-message automobile
 450       (:conc-name auto-)
 451     (model  :type string)
 452     (color  :type auto-color)
 453     (status :type auto-status :default :new))
 454   (proto:define-message auto-color
 455       (:conc-name auto-color-)
 456     (name    :type (or string null))
 457     (r-value :type integer)
 458     (g-value :type integer)
 459     (b-value :type integer)
 460     (proto:define-extension 1000 max))
 461   (proto:define-extend auto-color
 462       (:conc-name auto-color-)
 463     ((paint-type 1000) :type (or paint-type null)))
 464   (proto:define-message buy-car-request ()
 465     (auto :type automobile))
 466   (proto:define-message buy-car-response ()
 467     (price :type (or null uint32)))
 468   (proto:define-service buy-car ()
 469     (buy-car (buy-car-request => buy-car-response)
 470       :options (:deadline 1.0))))
 471
 472 (define-test extension-serialization ()
 473   (let* ((color1 (make-instance 'auto-color :r-value 100 :g-value 0 :b-value 100))
 474          (car1   (make-instance 'automobile :model "Audi" :color color1))
 475          (rqst1  (make-instance 'buy-car-request :auto car1))
 476          (color2 (make-instance 'auto-color :r-value 100 :g-value 0 :b-value 100))
 477          (car2   (make-instance 'automobile :model "Audi" :color color2))
 478          (rqst2  (make-instance 'buy-car-request :auto car2)))
 479     (setf (auto-color-paint-type color2) :metallic)
 480     (let ((ser1 (proto:serialize-object-to-bytes rqst1 'buy-car-request)))
 481       (assert-true (string= (with-output-to-string (s)
 482                               (proto:print-text-format rqst1 nil :stream s))
 483                             (with-output-to-string (s)
 484                               (proto:print-text-format
 485                                 (proto:deserialize-object 'buy-car-request ser1)  nil :stream s)))))
 486     (let ((ser2 (proto:serialize-object-to-bytes rqst2 'buy-car-request)))
 487       (assert-true (string= (with-output-to-string (s)
 488                               (proto:print-text-format rqst2 nil :stream s))
 489                             (with-output-to-string (s)
 490                               (proto:print-text-format
 491                                 (proto:deserialize-object 'buy-car-request ser2) nil :stream s)))))
 492     (let ((str1 (with-output-to-string (s)
 493                   (proto:print-text-format rqst1 nil :stream s)))
 494           (str2 (with-output-to-string (s)
 495                   (proto:print-text-format rqst2 nil :stream s))))
 496       (assert-false (string= str1 str2))
 497       (assert-false (search "paint_type:" str1 :test #'char=))
 498       (assert-true (search "paint_type:" str2 :test #'char=)))))
 499
 500
 501 ;; Group example
 502 ;; Supply :name to keep the names stable for string= below
 503 (proto:define-schema submessage-color-wheel
 504     (:package proto_test)
 505   (proto:define-message color-wheel1
 506       (:conc-name color-wheel- :name "ColorWheel")
 507     (proto:define-message metadata1     ;'metadata1' so we don't get class redefinition
 508         (:conc-name metadata- :name "Metadata")
 509       (author :type (or null string))
 510       (revision :type (or null string))
 511       (date :type (or null string)))
 512     (name :type string)
 513     (colors :type (list-of color1))
 514     (metadata :type (or null metadata1)))
 515   (proto:define-message color1
 516       (:conc-name color- :name "Color")
 517     (name :type (or null string))
 518     (r-value :type integer)
 519     (g-value :type integer)
 520     (b-value :type integer))
 521   (proto:define-message add-color1
 522       (:name "AddColor")
 523     (wheel :type color-wheel1)
 524     (color :type color1)))
 525
 526 ;; Supply :name to keep the names stable for string= below
 527 (proto:define-schema group-color-wheel
 528     (:package proto_test)
 529   (proto:define-message color-wheel2
 530       (:conc-name color-wheel- :name "ColorWheel")
 531     (name :type string)
 532     (colors :type (list-of color2))
 533     (proto:define-group metadata
 534         (:conc-name metadata-
 535          :index 3
 536          :arity :optional
 537          :name "Metadata")
 538       (author :type (or null string))
 539       (revision :type (or null string))
 540       (date :type (or null string))))
 541   (proto:define-message color2
 542       (:conc-name color- :name "Color")
 543     (name :type (or null string))
 544     (r-value :type integer)
 545     (g-value :type integer)
 546     (b-value :type integer))
 547   (proto:define-message add-color2
 548       (:name "AddColor")
 549     (wheel :type color-wheel2)
 550     (color :type color2)))
 551
 552 (define-test group-serialization ()
 553   (let* ((meta1  (make-instance 'metadata1 :revision "1.0"))
 554          (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata meta1))
 555          (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
 556          (rqst1  (make-instance 'add-color1 :wheel wheel1 :color color1))
 557          (meta2  (make-instance 'metadata :revision "1.0"))
 558          (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata meta2))
 559          (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
 560          (rqst2  (make-instance 'add-color2 :wheel wheel2 :color color2)))
 561     (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color1))
 562           (ser2 (proto:serialize-object-to-bytes rqst2 'add-color2)))
 563       (assert-true (string= (with-output-to-string (s)
 564                               (proto:print-text-format rqst1 nil :stream s))
 565                             (with-output-to-string (s)
 566                               (proto:print-text-format rqst2 nil :stream s))))
 567       (assert-true (string= (with-output-to-string (s)
 568                               (proto:print-text-format
 569                                 (proto:deserialize-object 'add-color1 ser1) nil :stream s))
 570                             (with-output-to-string (s)
 571                               (proto:print-text-format
 572                                 (proto:deserialize-object 'add-color2 ser2) nil :stream s)))))))
 573
 574
 575 ;; Type aliases
 576 (proto:define-schema type-alias-test
 577     (:package proto_test)
 578   (proto:define-type-alias lisp-integer-as-string ()
 579     :lisp-type integer
 580     :proto-type string
 581     :serializer princ-to-string
 582     :deserializer parse-integer)
 583   (proto:define-message type-alias-test-message ()
 584     (test-field :type (or null lisp-integer-as-string))))
 585
 586 (define-test type-aliases ()
 587   (assert-equal
 588    (proto-impl:proto-type
 589     (first (proto-impl:proto-fields
 590             (proto:find-message (proto:find-schema 'type-alias-test)
 591                                 'proto-test::type-alias-test-message))))
 592    "string")
 593   (let* ((msg1 (make-instance 'type-alias-test-message :test-field 5))
 594          (ser1 (proto:serialize-object-to-bytes msg1 'type-alias-test-message))
 595          (dser1 (deserialize-object 'type-alias-test-message ser1)))
 596     (assert-equal ser1 #(10 1 53) :test equalp)
 597     (assert-equal (slot-value msg1 'test-field)
 598                   (slot-value dser1 'test-field))))
 599
 600 (define-test-suite serialization-tests ()
 601   (basic-serialization
 602    basic-optimized-serialization
 603    text-serialization
 604    serialization-integrity
 605    #+qres geodata-serialization
 606    #+qres geodata-optimized-serialization
 607    extension-serialization
 608    group-serialization
 609    type-aliases))
 610
 611 (register-test 'serialization-tests)