| author |
Steve Losh <steve@stevelosh.com> |
| date |
Tue, 25 Aug 2020 00:08:28 -0400 |
| parents |
6c1bac83e3c9 |
| children |
af3ef34fe3ba |
(in-package :jarl/test)
;;;; Utils --------------------------------------------------------------------
(defmacro define-test (name &body body)
`(test ,(intern (concatenate 'string (symbol-name 'test-) (symbol-name name)))
(let ((*package* ,*package*))
,@body)))
(defun run-tests ()
(1am:run))
(defun json (string)
;; This makes it less miserable to write JSON strings in Lisp.
(substitute #\" #\' string))
(defun obj= (a b &key (test #'equal))
(and (= (hash-table-count a)
(hash-table-count b))
(not (maphash (lambda (ak av)
(multiple-value-bind (bv found) (gethash ak b)
(when (or (not found) (not (funcall test av bv)))
(return-from obj= nil))))
a))))
(defun vec= (a b &key (test #'equal))
(and (= (length a) (length b))
(every test a b)))
(defgeneric same (a b))
(defmethod same (a b)
(equal a b))
(defmethod same ((a vector) (b vector))
(vec= a b :test #'same))
(defmethod same ((a hash-table) (b hash-table))
(obj= a b :test #'same))
(defun h (&rest keys-and-values)
(alexandria:plist-hash-table keys-and-values :test #'equal))
(defun v (&rest values)
(coerce values 'vector))
(defun set-equal (x y)
(and (null (set-difference x y :test #'equal))
(null (set-difference y x :test #'equal))))
(defun slot= (a b slot)
(if (not (slot-boundp a slot))
(not (slot-boundp b slot))
(same (slot-value a slot)
(slot-value b slot))))
(defun slots= (a b &rest slots)
(every (alexandria:curry #'slot= a b) slots))
(defun check-reads-one-object (object string)
(with-input-from-string (s string)
(is (same object (jarl:read t s)))
(signals end-of-file (jarl:read t s))))
(defun check-discards-one-object (string)
(with-input-from-string (s string)
(is (null (multiple-value-list (jarl:read nil s))))
(signals end-of-file (jarl:read t s))))
(defun check-opaques-one-object (object string)
(with-input-from-string (s string)
;; Make sure we can read it as opaque JSON.
(let ((oj (jarl:read 'jarl::opaque-json s)))
;; Roundtrip it through print and read again and make sure it doesn't get
;; mangled.
(is (same object (jarl:read t (jarl:print oj nil)))))
(signals end-of-file (jarl:read t s))))
(defun check-roundtrips (object)
(is (same object (jarl:read t (jarl:print object nil)))))
(defun check-errors (line col string)
(dolist (class '(t nil)) ; todo check discarding errors too
(handler-case
(progn
(jarl:read class string)
(error "Should have signaled a json-parsing-error when parsing ~S but didn't."
class))
(jarl::json-parsing-error (e)
(is (equal (list class line col)
(list class (jarl:line e) (jarl:column e))))))))
;;;; Basic Tests --------------------------------------------------------------
(defmacro define-basic-tests (name &rest clauses)
`(define-test ,name
,@(loop :for (object string) :in clauses :collect
(alexandria:once-only (object string)
`(let ((,string (json ,string)))
; Check that the entire string deserializes to the expected form.
(check-reads-one-object ,object ,string)
; Check that we can roundtrip the form reliably.
(check-roundtrips ,object)
; Check that we can parse it opaquely too.
(check-opaques-one-object ,object ,string)
; Check that we can discard it safely.
(check-discards-one-object ,string))))))
(define-basic-tests null
(nil "null"))
(define-basic-tests keywords
(:true "true")
(:false "false"))
(define-basic-tests integers
(0 "0")
(0 "-0")
(1 "1")
(-1 "-1")
(10 "10")
(-10 "-10")
(123456789123456789123456789 "123456789123456789123456789")
(-123456789123456789123456789 "-123456789123456789123456789"))
(define-basic-tests floats
(0.0d0 "0e0")
(0.0d0 "0.0e0")
(-0.0d0 "-0.0e0")
(1.0d0 "1e0")
(1.0d0 "1e+0")
(1.0d0 "1e-0")
(1.2d0 "1.2e0")
(1.2d0 "1.2e+0")
(1.2d0 "1.2e-0")
(100.0d0 "1e2")
(100.0d0 "1e+2")
(123.4d0 "0.01234e+4")
(0.1234d0 "1.234e-1")
(1.234d-10 "1.234e-10"))
(define-basic-tests strings
("" "''")
(" " "' '")
(" " " ' ' ")
("foo" "'foo'")
("\"foo" "'\\'foo'")
("f\\oo" "'f\\\\oo'")
((format nil "foo~%bar") "'foo\\nbar'")
((format nil "foo~Abar" #\tab) "'foo\\tbar'")
((format nil "u: ~A" (code-char #x1234)) "'u: \\u1234'")
((format nil "(~A)" (code-char #xCAFE)) "'(\\uCaFe)'")
((format nil "~A~A" (code-char #xABCD) (code-char #xBEEF)) "'\\uABCD\\ubeef'"))
(define-basic-tests vectors
(#() "[]")
(#(1) "[1]")
(#(1 2 3) "[1,2,3]")
(#("meow" "wow") "['meow', 'wow']")
(#(1 nil "meow" :false -2 :true) "[1, null, 'meow', false, -2, true]")
(#(#(1 2) #() #(3.0d0 4.0d0 5.0d0)) "[[1, 2], [], [3e0, 40e-1, 0.5e1]]"))
(define-basic-tests objects
((h) "{}")
((h "foo" 1 "bar" 2) "{'foo': 1, 'bar': 2}")
((h "foo" 1 "bar" 2) "{'bar': 2, 'foo': 1}")
((h "foo" (h "a" nil "b" :false)
"bar" :true
"baz" (v (h) (h) (h)))
"{'foo': {'a': null, 'b': false},
'bar': true,
'baz': [{},{},{}]}"))
(define-basic-tests whitespace
(#() "[ ]")
((h) " { }")
((v (v) (h)) " [[ ] , { }]")
(#(1 2 3 4 5) " [ 1, 2 ,3, 4,5]"))
(define-test multiple-objects
(with-input-from-string (s (json "{} 1 2 [true, false] {'foo': null}"))
(is (same (h) (jarl:read t s)))
(is (same 1 (jarl:read t s)))
(is (same 2 (jarl:read t s)))
(is (same #(:true :false) (jarl:read t s)))
(is (same (h "foo" nil) (jarl:read t s)))
(is (eql :eof (jarl:read t s nil :eof)))
(signals end-of-file (jarl:read t s))))
;;;; Real-World Data ----------------------------------------------------------
(defmacro define-file-test (name (object path) &body body)
(alexandria:with-gensyms (string)
`(define-test ,name
(let ((,string (alexandria:read-file-into-string ,path)))
;; Check that discarding works.
(check-discards-one-object ,string)
(let ((,object (jarl:read t ,string)))
;; Check that we can discard it.
(check-roundtrips ,object)
;; Other test-specific checks.
,@body)))))
(define-file-test github/sjl (o "test/data/github/sjl.json")
(is (string= "sjl" (gethash "login" o)))
(is (= 182 (gethash "public_repos" o))))
(define-file-test github/sjl-repos (o "test/data/github/sjl-repos.json")
(is (set-equal '(:true :false)
(remove-duplicates (map 'list (lambda (r) (gethash "fork" r)) o)))))
(define-file-test reddit/r-common_lisp (o "test/data/reddit/r-common_lisp.json"))
(define-file-test jira/MVNCENTRAL (o "test/data/jira/MVNCENTRAL.json"))
;;;; Error Tests --------------------------------------------------------------
(defmacro define-error-tests (name &rest clauses)
`(define-test ,name
,@(loop :for (line col string) :in clauses
:collect `(check-errors ,line ,col (json ,string)))))
(define-error-tests trash
(1 1 "meow")
(1 3 "number")
(1 4 "truthy")
(1 3 "famous")
(1 1 "<what>")
(1 1 "(cons nil nil)")
(1 1 "NULL")
(1 1 "undefined")
(1 1 "NaN")
(1 1 ":::")
(1 1 "&rest")
(1 1 "]")
(1 1 "}"))
(define-error-tests bad-eof
(1 4 "nul")
(1 4 "tru")
(1 5 "fals")
(1 2 "[")
(1 7 "['no',")
(1 6 "['no'")
(1 5 "[[[{")
(1 2 "{")
(1 6 "{'foo")
(1 7 "{'foo'")
(1 8 "{'foo':")
(1 10 "{'foo': 1")
(1 11 "{'foo': 1,")
(1 2 "'")
(1 7 "'whops")
(1 9 "'whops\\'")
(1 2 "1.")
(1 2 "1e")
(1 3 "1e-")
(1 3 "1e+")
(1 1 "-"))
(define-error-tests mispaired-delimiters
(1 2 "{]")
(1 2 "[}")
(1 10 "[1, [2, 3}]"))
(define-error-tests commas
(1 1 ",")
(1 2 "[,]")
(1 4 "[1 2]")
(1 4 "[1,,2]")
(1 2 "{,}")
(1 9 "{'a': 1,}")
(1 9 "{'a': 1,, 'b': 2}")
(1 5 "{'a', 1}")
(1 2 "{,'a': 1}"))
(define-error-tests unescaped-string-chars
;; todo more of these
(2 0 (format nil "'~%'")))
(define-error-tests bad-unicode-sequence
;; todo more of these
(1 4 "'\\uNOPE'")
(1 6 "'\\u12'")
(1 4 "'\\u 1234'")
(1 4 "'\\uUUID'"))
(define-error-tests bad-escape
;; todo more of these
(1 3 "'\\x'"))
(define-error-tests leading-zero
(1 1 "01")
(1 1 "00")
(1 1 "00.0"))
(define-test size-limit
;; TODO Add some more of these.
(let ((jarl::*read-size-limit* 9))
(is (same #(1 2 3) (jarl:read t "[1, 2, 3]")))
(signals jarl::json-size-limit-exceeded-error (jarl:read t "[1, 2, 3 ]"))
(signals jarl::json-size-limit-exceeded-error (jarl:read t " null"))
(signals jarl::json-size-limit-exceeded-error (jarl:read t "\"foobarbaz"))
(signals jarl::json-size-limit-exceeded-error (jarl:read t "[[[[[[[[[[[[[[[[[[["))
(signals jarl::json-size-limit-exceeded-error (jarl:read nil "[1, 2, 3 ]"))))
(define-test depth-limit
;; TODO Add some more of these.
(let ((jarl::*read-depth-limit* 3))
(is (same #(#(#(1))) (jarl:read t "[[[1]]]")))
(signals jarl::json-depth-limit-exceeded-error (jarl:read t "[[[[1]]]]"))
(signals jarl::json-depth-limit-exceeded-error (jarl:read t (json "[{'foo': [[1]]}]")))
(signals jarl::json-depth-limit-exceeded-error (jarl:read nil "[[[[1]]]]"))
(signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]")))))
;;;; MOP ----------------------------------------------------------------------
(defclass foo ()
((i :json number :initarg :i)
(s :json string :initarg :s)
(k :json keyword :initarg :k)
(n :json null :initarg :n)
(h :json hash-table :initarg :h)
(v :json vector :initarg :v)
(any :json t :initarg :any))
(:metaclass jarl:json-class))
(defclass bar ()
((id :json (or null number) :initarg :id)
(foos :json (vector foo) :initarg :foos))
(:metaclass jarl:json-class))
(defun foo (&rest args)
(apply #'make-instance 'foo args))
(defun bar (&rest args)
(apply #'make-instance 'bar args))
(defmethod same ((a foo) (b foo))
(slots= a b 'i 's 'k 'n 'h 'v 'any))
(defmethod same ((a bar) (b bar))
(slots= a b 'id 'foos))
(defmacro define-class-tests (name &body clauses)
`(define-test ,name
,@(loop :for (class string . initargs) :in clauses
:collect `(is (same (make-instance ',class ,@initargs)
(jarl:read ',class (json ,string)))))))
(define-class-tests basic-class
(foo "{}")
(foo "{'i': 1}" :i 1)
(foo "{'i': 1, 's': 'meow'}" :i 1 :s "meow")
(foo "{ 'i': 2,
's': 'wow',
'k': false,
'n': null,
'h': {'x': 'hello', 'y': -1},
'v': [true, 1,2, 'x'],
'any': 0.0 }"
:i 2
:s "wow"
:k :false
:n nil
:h (h "x" "hello" "y" -1)
:v (v :true 1 2 "x")
:any 0d0))
(define-class-tests nested-classes
(bar "{}")
(bar "{'id': 1}" :id 1)
(bar "{'id': 1, 'foos': []}" :id 1 :foos (v))
(bar "{'id': null, 'foos': [{'i': 10}, {'n': null, 'v': []}]}"
:id nil
:foos (v (foo :i 10) (foo :n nil :v (v)))))
;;;; Wrappers -----------------------------------------------------------------
(defclass w ()
((names :type list :initarg :names)))
(define-test global-wrappers
(jarl::set-global-wrapper
'w '(vector string)
:read (lambda (strings) (make-instance 'w :names (coerce strings 'list)))
:print (lambda (w) (coerce (slot-value w 'names) 'vector)))
(jarl::set-global-wrapper
'uuid:uuid 'string
:read 'uuid:make-uuid-from-string
:print 'princ-to-string)
(unwind-protect
(progn
(is (equal `("a" "b" "c")
(slot-value (jarl:read 'w (json "['a', 'b', 'c']")) 'names)))
(is (uuid:uuid=
(uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
(jarl:read 'uuid:uuid (json "'733db032-c573-4eaa-af6b-0ff7c99302d2'"))))
(is (string= (json "'733DB032-C573-4EAA-AF6B-0FF7C99302D2'")
(string-upcase
(jarl:print
(uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
nil))))
(is (string= (json "['meow','wow']")
(jarl:print (make-instance 'w :names '("meow" "wow")) nil))))
(map nil 'jarl::remove-global-wrapper '(w uuid:uuid))))
(define-test with-wrappers
(jarl::with-wrappers
((uuid:uuid 'string :read 'uuid:make-uuid-from-string :print 'princ-to-string)
(w '(vector string)
:read (lambda (strings) (make-instance 'w :names (coerce strings 'list)))
:print (lambda (w) (coerce (slot-value w 'names) 'vector))))
(is (equal `("a" "b" "c")
(slot-value (jarl:read 'w (json "['a', 'b', 'c']")) 'names)))
(is (uuid:uuid=
(uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
(jarl:read 'uuid:uuid (json "'733db032-c573-4eaa-af6b-0ff7c99302d2'"))))
(is (string= (json "'733DB032-C573-4EAA-AF6B-0FF7C99302D2'")
(string-upcase
(jarl:print
(uuid:make-uuid-from-string "733DB032-C573-4EAA-AF6B-0FF7C99302D2")
nil))))
(is (string= (json "['meow','wow']")
(jarl:print (make-instance 'w :names '("meow" "wow")) nil)))))
(defclass w2 ()
((name :initarg :name)))
(defun wrap1 (string)
(make-instance 'w2 :name (coerce string 'list)))
(defun wrap2 (string)
(make-instance 'w2 :name (reverse string)))
(defun unwrap1 (w2)
(coerce (slot-value w2 'name) 'string))
(defun unwrap2 (w2)
(reverse (slot-value w2 'name)))
(define-test nested-wrappers
(jarl::with-wrappers ((w2 'string :read #'wrap1 :print #'unwrap1))
(is (equal '(#\a #\b #\c)
(slot-value (jarl:read 'w2 (json "'abc'")) 'name)))
(is (equal (json "'abc'")
(jarl:print (make-instance 'w2 :name '(#\a #\b #\c)) nil)))
(jarl::with-wrappers ((w2 'string :read #'wrap2 :print #'unwrap2))
(is (equal "cba"
(slot-value (jarl:read 'w2 (json "'abc'")) 'name)))
(is (equal (json "'abc'")
(jarl:print (make-instance 'w2 :name "cba") nil))))))
(define-test half-wrappers
(jarl::with-wrappers ((w2 'string :read #'wrap1))
(is (equal '(#\a #\b #\c) (slot-value (jarl:read 'w2 (json "'abc'")) 'name)))
(signals error (jarl:print (make-instance 'w2 :name '(#\a #\b #\c)) nil)))
(jarl::with-wrappers ((w2 'string :print #'unwrap1))
(signals error (jarl:read 'w2 (json "'abc'")))
(is (equal (json "'abc'")
(jarl:print (make-instance 'w2 :name '(#\a #\b #\c)) nil)))))
;;;; Allow Print/Read ---------------------------------------------------------
(defclass apr ()
((id :json number :initarg :id))
(:metaclass jarl:json-class))
(defclass apr/deny-read ()
((id :json number :initarg :id))
(:metaclass jarl:json-class)
(:allow-read nil))
(defclass apr/deny-print ()
((id :json number :initarg :id))
(:metaclass jarl:json-class)
(:allow-print nil))
(define-test allow-read
(is (= 1 (slot-value (jarl:read 'apr (json "{'id': 1}")) 'id)))
(is (= 1 (slot-value (jarl:read 'apr/deny-print (json "{'id': 1}")) 'id)))
(signals error (jarl:read 'apr/deny-read (json "{'id': 1}"))))
(define-test allow-print
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr :id 1) nil)))
(is (string= (json "{'id':1}") (jarl:print (make-instance 'apr/deny-read :id 1) nil)))
(signals error (jarl:print (make-instance 'apr/deny-print :id 1) nil)))
;;;; After Read/Before Print --------------------------------------------------
(define-condition validation-error (error) ())
(defun validate-small (i)
(if (> (abs i) 10)
(error 'validation-error)
i))
(defclass arbp ()
((i :json number :initarg :i
:json/after-read validate-small)
(s :json string :initarg :s
:json/after-read string-upcase
:json/before-print string-downcase))
(:metaclass jarl:json-class))
(define-test before-print
(is (string= (json "{'s':'hello'}")
(jarl:print (make-instance 'arbp :s "Hello") nil))))
(define-test after-read
(is (string= "HELLO" (slot-value (jarl:read 'arbp (json "{'s':'Hello'}")) 's)))
(is (= 5 (slot-value (jarl:read 'arbp (json "{'i':5}")) 'i)))
(signals validation-error (jarl:read 'arbp (json "{'i':999}"))))
;;;; Fuzz Utilities -----------------------------------------------------------
(defparameter *basic-chars*
" abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")
(defparameter *gen-depth* 0)
(defparameter *max-gen-depth* 5)
(chancery:define-rule gen/keyword
:true
:false)
(chancery:define-rule gen/null
nil)
(chancery:define-rule (random-char :distribution :weighted)
(50 (chancery:eval (string (alexandria:random-elt *basic-chars*))))
(1 "\\\\")
(1 "\\\"")
(1 "\\n")
(1 "\\b")
(1 "\\f")
(1 "\\t")
;; todo more unicode
(1 (chancery:eval (format nil "\\u~4,'0X" (char-code (alexandria:random-elt *basic-chars*))))))
(defun random-string ()
(with-output-to-string (s)
(dotimes (i (random 20))
(write-string (random-char) s))))
(chancery:define-rule (gen/string :distribution :weighted)
(1 "")
(5 random-string))
(chancery:define-rule gen/float
0.0d0
(chancery:eval (- (random 1d12) 0.5d12)))
(defun gen/integer ()
(- (random 100000) 50000))
(chancery:define-rule gen/number
0
0d0
gen/integer
gen/float)
(defun gen/vector ()
(if (> *gen-depth* *max-gen-depth*)
(vector)
(let ((result (make-array (random 20)))
(*gen-depth* (1+ *gen-depth*)))
(dotimes (i (length result))
(setf (aref result i) (gen/any)))
result)))
(defun gen/object ()
(if (> *gen-depth* *max-gen-depth*)
(h)
(let* ((result (h))
(*gen-depth* (1+ *gen-depth*))
(keys (remove-duplicates (loop :repeat (random 10)
:collect (gen/string))
:test #'equal)))
(dolist (k keys)
(setf (gethash k result) (gen/any)))
result)))
(chancery:define-rule gen/any
gen/keyword
gen/null
gen/string
gen/number
gen/vector
gen/object)
(defun copy-and-map-hash-table (function hash-table)
(let ((result (make-hash-table :test #'equal
:size (hash-table-count hash-table))))
(maphash (lambda (k v)
(setf (gethash k result) (funcall function v)))
hash-table)
result))
(defgeneric to-jarl (from o)
(:method (from o) (declare (ignore from)) o)
(:method (from (o string)) (declare (ignore from)) o))
(defmethod to-jarl (from (o vector))
(map 'vector (alexandria:curry #'to-jarl from) o))
(defmethod to-jarl (from (o hash-table))
(copy-and-map-hash-table (alexandria:curry #'to-jarl from) o))
(defgeneric from-jarl (to o)
(:method (to o) (declare (ignore to)) o)
(:method (to (o string)) (declare (ignore to)) o))
(defmethod from-jarl (to (o vector))
(map 'vector (alexandria:curry #'from-jarl to) o))
(defmethod from-jarl (to (o hash-table))
(copy-and-map-hash-table (alexandria:curry #'from-jarl to) o))
;;;; Yason Fuzzing ------------------------------------------------------------
(defun yason/read (string)
(let ((yason:*parse-json-arrays-as-vectors* t)
(yason:*parse-json-booleans-as-symbols* t)
(*read-default-float-format* 'double-float))
(yason:parse string)))
(defun yason/print (object)
(let ((yason:*parse-json-arrays-as-vectors* t)
(yason:*parse-json-booleans-as-symbols* t)
(*read-default-float-format* 'double-float))
(with-output-to-string (s)
(yason:encode object s))))
(defmethod to-jarl ((from (eql 'yason)) (o symbol))
(alexandria:make-keyword o))
(defmethod to-jarl ((from (eql 'yason)) (o null))
nil)
(defmethod from-jarl ((to (eql 'yason)) (o symbol))
(ecase o
((nil) nil)
(:true 'yason:true)
(:false 'yason:false)))
(define-test fuzz-against-yason
(dotimes (i 1000)
(let* ((o (gen/any))
(js (jarl:print o nil))
(ys (yason/print (from-jarl 'yason o))))
(is (same (jarl:read t js)
(to-jarl 'yason (yason/read js))))
(is (same (jarl:read t ys)
(to-jarl 'yason (yason/read ys)))))))