Commit cb81e266 authored by  Hayley Patton's avatar Hayley Patton 🐢

Add fuzzing for object rendering and parsing, fix rendering of vague-objects

parent 322c03c7
......@@ -76,12 +76,12 @@
(defun verify-object-hash (object hash)
"Verify a total hash as generated by HASH-OBJECT."
(let ((hash (alexandria:copy-array (subseq hash 0 32)
:element-type '(unsigned-byte 8)
:fill-pointer nil
:adjustable nil)))
(ironclad:constant-time-equal hash
(hash-object object))))
(let ((their-hash (alexandria:copy-array (subseq hash 0 32)
:element-type '(unsigned-byte 8)
:fill-pointer nil
:adjustable nil))
(our-hash (hash-object object)))
(ironclad:constant-time-equal their-hash our-hash)))
;;; Pronounceable verification codes.
;; Not dissimilar to https://github.com/deoxxa/proquint/blob/master/encode.js
......
......@@ -113,8 +113,10 @@ string; but RENDER-OBJECT will emit Netfarm standard format text."))
stream))
(write-line "---" stream)
(render-hash-table (vague-object-metadata object) stream)
(terpri stream)
(write-line "---" stream)
(render-hash-table (vague-object-values object) stream)
(terpri stream)
(when emit-computed-values
(maybe-write-vague-computed-values object stream)))
......
......@@ -35,7 +35,7 @@
(defvar *tree-depth* *reader-depth*)
(defun random-tree-generator (&key
(node-generator (funcall 'random-datum-generator))
(node-generator (random-datum-generator))
(branch-probability 0.5)
(length 5))
(lambda ()
......@@ -65,21 +65,31 @@
:true
:false))))))
(defgeneric equal-dwim (a b)
(:method (a b) nil))
(defclass fuzz-class ()
((slot-a :initarg :slot-a)
(slot-b :initarg :slot-b))
(:metaclass netfarm-class))
(defun random-object-generator (&key
(slot-generator (random-datum-generator)))
(lambda ()
(make-instance 'fuzz-class
:slot-a (funcall slot-generator)
:slot-b (funcall slot-generator))))
(defmethod equal-dwim ((a string) (b string))
(string= a b))
(defmethod equal-dwim ((a number) (b number))
(= a b))
(defmethod equal-dwim ((a vector) (b vector))
(and (= (length a) (length b))
(every #'= a b)))
(defmethod equal-dwim ((a list) (b list))
(and (= (length a) (length b))
(every #'equal-dwim a b)))
(defmethod equal-dwim ((a symbol) (b symbol))
(eql a b))
(defgeneric equal-dwim (a b)
(:method (a b) nil)
(:method ((a string) (b string))
(string= a b))
(:method ((a number) (b number))
(= a b))
(:method ((a vector) (b vector))
(and (= (length a) (length b))
(every #'= a b)))
(:method ((a list) (b list))
(and (= (length a) (length b))
(every #'equal-dwim a b)))
(:method ((a symbol) (b symbol))
(eql a b)))
(defun fuzz (fn tests input-generator &key reverse-fn (test #'equal))
(let ((errors 0)
......@@ -92,7 +102,10 @@
(incf errors)
(push input error-cases)
(format t "BANG! The input ~s raises the condition ~a on test #~d.~%"
input c test-n)))))
input c test-n)
(when (> errors 100)
(return-from fuzz
(values nil errors error-cases)))))))
(values (zerop errors)
errors
error-cases)))
......@@ -38,7 +38,18 @@
(true (fuzz #'render 10000 (random-tree-generator)
:reverse-fn #'parse
:test #'equal-dwim)
"Fuzz testing the renderer and parser failed, see the 'BANG' messages above"))
"Fuzz testing the renderer and parser failed, see the 'BANG' messages above")
(let ((fuzz-class (find-class 'fuzz-class)))
(true (fuzz #'render-object 10000 (random-object-generator)
:reverse-fn (lambda (text)
(apply-class (parse-block text)
fuzz-class))
:test (lambda (object1 object2)
(and (equal-dwim (slot-value object1 'slot-a)
(slot-value object2 'slot-a))
(equal-dwim (slot-value object1 'slot-b)
(slot-value object2 'slot-b))))))))
(define-test read-signature
:parent parser-tests
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment