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 #xFF #xFF #xFF #xFF #xFF #x01)))
 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 #xFF #xFF #xFF #xFF #xFF #x01)))
 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 (proto:define-schema empty-message-optimize-speed-test
 376     (:package proto_test :optimize :speed)
 377   (proto:define-message speed-empty ())
 378   (proto:define-message speed-optional ()
 379     (foo :type (or null speed-empty)))
 380   (proto:define-message speed-repeated ()
 381     (foo :type (proto:list-of speed-empty))))
 382
 383 (proto:define-schema empty-message-optimize-space-test
 384     (:package proto_test :optimize :space)
 385   (proto:define-message space-empty ())
 386   (proto:define-message space-optional ()
 387     (foo :type (or null space-empty)))
 388   (proto:define-message space-repeated ()
 389     (foo :type (proto:list-of space-empty))))
 390
 391 (define-test empty-message-serialization ()
 392   (let ((speed0 (make-instance 'speed-empty))
 393         (speed1 (make-instance 'speed-optional))
 394         (speed2 (make-instance 'speed-repeated))
 395         (space0 (make-instance 'space-empty))
 396         (space1 (make-instance 'space-optional))
 397         (space2 (make-instance 'space-repeated)))
 398     (setf (slot-value speed1 'foo) speed0)
 399     (setf (slot-value space1 'foo) space0)
 400     (push speed0 (slot-value speed2 'foo))
 401     (push space0 (slot-value space2 'foo))
 402    (let ((ser-speed0 (serialize-object-to-bytes speed0 (type-of speed0)))
 403          (ser-speed1 (serialize-object-to-bytes speed1 (type-of speed1)))
 404          (ser-speed2 (serialize-object-to-bytes speed2 (type-of speed2)))
 405          (ser-space0 (serialize-object-to-bytes space0 (type-of space0)))
 406          (ser-space1 (serialize-object-to-bytes space1 (type-of space1)))
 407          (ser-space2 (serialize-object-to-bytes space2 (type-of space2))))
 408      (assert-true (equalp ser-speed0 #()))
 409      (assert-true (equalp ser-speed1 #(#x0A #x00)))
 410      (assert-true (equalp ser-speed2 #(#x0A #x00)))
 411      (assert-true (equalp ser-space0 #()))
 412      (assert-true (equalp ser-space1 #(#x0A #x00)))
 413      (assert-true (equalp ser-space2 #(#x0A #x00))))))
 414
 415
 416 #+qres (progn
 417
 418 (eval-when (:compile-toplevel :load-toplevel :execute)
 419
 420 (defclass geodata ()
 421   ((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries)
 422    (regions :type (proto:list-of qres-core::region) :initform () :initarg :regions)
 423    (cities :type (proto:list-of qres-core::city) :initform () :initarg :cities)
 424    (airports :type (proto:list-of qres-core::airport) :initform () :initarg :airports)))
 425
 426 )       ;eval-when
 427
 428 (defvar *geodata-schema*
 429   (proto:generate-schema-for-classes
 430    '(qres-core::country qres-core::region qres-core::region-key
 431      qres-core::city qres-core::airport
 432      qres-core::timezone qres-core::tz-variation
 433      qres-core::currency qres-core::country-currencies
 434      qres-core::carrier
 435      geodata)
 436    :install t))
 437
 438 (define-test geodata-serialization ()
 439   (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
 440          (regions   (loop for v being the hash-values of (qres-core::region-business-data) collect v))
 441          (cities    (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
 442          (airports  (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v)))
 443          (geodata (make-instance 'geodata
 444                     :countries countries
 445                     :regions regions
 446                     :cities cities
 447                     :airports airports)))
 448     (let ((gser (proto:serialize-object-to-bytes geodata 'geodata)))
 449       (assert-true (equalp gser (proto:serialize-object-to-bytes
 450                                  (proto:deserialize-object 'geodata gser) 'geodata))))))
 451
 452 (define-test geodata-optimized-serialization ()
 453   (dolist (class '(qres-core::country qres-core::region qres-core::region-key
 454                    qres-core::city qres-core::airport
 455                    qres-core::timezone qres-core::tz-variation
 456                    qres-core::currency qres-core::country-currencies
 457                    qres-core::carrier
 458                    geodata))
 459     (let ((message (find-message *geodata-schema* class)))
 460       (eval (generate-object-size  message))
 461       (eval (generate-serializer   message))
 462       (eval (generate-deserializer message))))
 463   (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
 464          (regions   (loop for v being the hash-values of (qres-core::region-business-data) collect v))
 465          (cities    (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
 466          (airports  (loop for v being the hash-values of (car (qres-core::airport-business-data)) collect (car v)))
 467          (geodata (make-instance 'geodata
 468                     :countries countries
 469                     :regions regions
 470                     :cities cities
 471                     :airports airports)))
 472     (let ((gser (proto:serialize-object-to-bytes geodata 'geodata)))
 473       (assert-true (equalp gser (proto:serialize-object-to-bytes
 474                                   (proto:deserialize-object 'geodata gser) 'geodata))))))
 475
 476 )       ;#+qres
 477
 478
 479 ;; Extension example
 480 (proto:define-schema automobile
 481     (:package proto_test
 482      :optimize :speed)
 483   (proto:define-enum auto-status ()
 484     new
 485     used)
 486   (proto:define-enum paint-type ()
 487     normal
 488     metallic)
 489   (proto:define-message automobile
 490       (:conc-name auto-)
 491     (model  :type string)
 492     (color  :type auto-color)
 493     (status :type auto-status :default :new))
 494   (proto:define-message auto-color
 495       (:conc-name auto-color-)
 496     (name    :type (or string null))
 497     (r-value :type integer)
 498     (g-value :type integer)
 499     (b-value :type integer)
 500     (proto:define-extension 1000 max))
 501   (proto:define-extend auto-color
 502       (:conc-name auto-color-)
 503     ((paint-type 1000) :type (or paint-type null)))
 504   (proto:define-message buy-car-request ()
 505     (auto :type automobile))
 506   (proto:define-message buy-car-response ()
 507     (price :type (or null uint32)))
 508   (proto:define-service buy-car ()
 509     (buy-car (buy-car-request => buy-car-response)
 510       :options (:deadline 1.0))))
 511
 512 (define-test extension-serialization ()
 513   (let* ((color1 (make-instance 'auto-color :r-value 100 :g-value 0 :b-value 100))
 514          (car1   (make-instance 'automobile :model "Audi" :color color1))
 515          (rqst1  (make-instance 'buy-car-request :auto car1))
 516          (color2 (make-instance 'auto-color :r-value 100 :g-value 0 :b-value 100))
 517          (car2   (make-instance 'automobile :model "Audi" :color color2))
 518          (rqst2  (make-instance 'buy-car-request :auto car2)))
 519     (setf (auto-color-paint-type color2) :metallic)
 520     (let ((ser1 (proto:serialize-object-to-bytes rqst1 'buy-car-request)))
 521       (assert-true (string= (with-output-to-string (s)
 522                               (proto:print-text-format rqst1 nil :stream s))
 523                             (with-output-to-string (s)
 524                               (proto:print-text-format
 525                                 (proto:deserialize-object 'buy-car-request ser1)  nil :stream s)))))
 526     (let ((ser2 (proto:serialize-object-to-bytes rqst2 'buy-car-request)))
 527       (assert-true (string= (with-output-to-string (s)
 528                               (proto:print-text-format rqst2 nil :stream s))
 529                             (with-output-to-string (s)
 530                               (proto:print-text-format
 531                                 (proto:deserialize-object 'buy-car-request ser2) nil :stream s)))))
 532     (let ((str1 (with-output-to-string (s)
 533                   (proto:print-text-format rqst1 nil :stream s)))
 534           (str2 (with-output-to-string (s)
 535                   (proto:print-text-format rqst2 nil :stream s))))
 536       (assert-false (string= str1 str2))
 537       (assert-false (search "paint_type:" str1 :test #'char=))
 538       (assert-true (search "paint_type:" str2 :test #'char=)))))
 539
 540
 541 ;; Group example
 542 ;; Supply :name to keep the names stable for string= below
 543 (proto:define-schema submessage-color-wheel
 544     (:package proto_test)
 545   (proto:define-message color-wheel1
 546       (:conc-name color-wheel- :name "ColorWheel")
 547     (proto:define-message metadata1     ;'metadata1' so we don't get class redefinition
 548         (:conc-name metadata- :name "Metadata")
 549       (author :type (or null string))
 550       (revision :type (or null string))
 551       (date :type (or null string)))
 552     (name :type string)
 553     (colors :type (list-of color1))
 554     (metadata :type (or null metadata1)))
 555   (proto:define-message color1
 556       (:conc-name color- :name "Color")
 557     (name :type (or null string))
 558     (r-value :type integer)
 559     (g-value :type integer)
 560     (b-value :type integer))
 561   (proto:define-message add-color1
 562       (:name "AddColor")
 563     (wheel :type color-wheel1)
 564     (color :type color1)))
 565
 566 ;; Supply :name to keep the names stable for string= below
 567 (proto:define-schema group-color-wheel
 568     (:package proto_test)
 569   (proto:define-message color-wheel2
 570       (:conc-name color-wheel- :name "ColorWheel")
 571     (name :type string)
 572     (colors :type (list-of color2))
 573     (proto:define-group metadata
 574         (:conc-name metadata-
 575          :index 3
 576          :arity :optional
 577          :name "Metadata")
 578       (author :type (or null string))
 579       (revision :type (or null string))
 580       (date :type (or null string))))
 581   (proto:define-message color2
 582       (:conc-name color- :name "Color")
 583     (name :type (or null string))
 584     (r-value :type integer)
 585     (g-value :type integer)
 586     (b-value :type integer))
 587   (proto:define-message add-color2
 588       (:name "AddColor")
 589     (wheel :type color-wheel2)
 590     (color :type color2)))
 591
 592 (define-test group-serialization ()
 593   (let* ((meta1  (make-instance 'metadata1 :revision "1.0"))
 594          (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata meta1))
 595          (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
 596          (rqst1  (make-instance 'add-color1 :wheel wheel1 :color color1))
 597          (meta2  (make-instance 'metadata :revision "1.0"))
 598          (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata meta2))
 599          (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
 600          (rqst2  (make-instance 'add-color2 :wheel wheel2 :color color2)))
 601     (let ((ser1 (proto:serialize-object-to-bytes rqst1 'add-color1))
 602           (ser2 (proto:serialize-object-to-bytes rqst2 'add-color2)))
 603       (assert-true (string= (with-output-to-string (s)
 604                               (proto:print-text-format rqst1 nil :stream s))
 605                             (with-output-to-string (s)
 606                               (proto:print-text-format rqst2 nil :stream s))))
 607       (assert-true (string= (with-output-to-string (s)
 608                               (proto:print-text-format
 609                                 (proto:deserialize-object 'add-color1 ser1) nil :stream s))
 610                             (with-output-to-string (s)
 611                               (proto:print-text-format
 612                                 (proto:deserialize-object 'add-color2 ser2) nil :stream s)))))))
 613
 614
 615 ;; Type aliases
 616 (proto:define-schema type-alias-test
 617     (:package proto_test)
 618   (proto:define-type-alias lisp-integer-as-string ()
 619     :lisp-type integer
 620     :proto-type string
 621     :serializer princ-to-string
 622     :deserializer parse-integer)
 623   (proto:define-message type-alias-test-message ()
 624     (test-field :type (or null lisp-integer-as-string))))
 625
 626 (define-test type-aliases ()
 627   (assert-equal
 628    (proto-impl:proto-type
 629     (first (proto-impl:proto-fields
 630             (proto:find-message (proto:find-schema 'type-alias-test)
 631                                 'proto-test::type-alias-test-message))))
 632    "string")
 633   (let* ((msg1 (make-instance 'type-alias-test-message :test-field 5))
 634          (ser1 (proto:serialize-object-to-bytes msg1 'type-alias-test-message))
 635          (dser1 (deserialize-object 'type-alias-test-message ser1)))
 636     (assert-equal ser1 #(10 1 53) :test #'equalp)
 637     (assert-equal (slot-value msg1 'test-field)
 638                   (slot-value dser1 'test-field))))
 639
 640 (define-test-suite serialization-tests ()
 641   (basic-serialization
 642    basic-optimized-serialization
 643    text-serialization
 644    serialization-integrity
 645    #+qres geodata-serialization
 646    #+qres geodata-optimized-serialization
 647    extension-serialization
 648    group-serialization
 649    empty-message-serialization
 650    type-aliases))
 651
 652 (register-test 'serialization-tests)