Refactor fuzzing code, fuzz in both directions
author |
Steve Losh <steve@stevelosh.com> |
date |
Thu, 13 Aug 2020 22:33:26 -0400 |
parents |
d23a34c34dc3 |
children |
e524dd8f7940 |
(in-package :jarl)
;;;; Object Parsers -----------------------------------------------------------
(defun lisp-case-to-snake-case (string)
"Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake cased `\"foo_bar\"`."
(substitute #\_ #\- (string-downcase string)))
(defclass json-class (standard-class)
((slot-name-to-json-name :accessor slot-name-to-json-name
:initarg :slot-name-to-json-name
:initform 'lisp-case-to-snake-case)
(unknown-slots :accessor unknown-slots
:initarg :unknown-slots
:initform :discard)
(name-initarg-map :accessor name-initarg-map)
(slot-name-alist :accessor slot-name-alist)))
(defmethod c2mop:validate-superclass ((class json-class) (superclass standard-class))
t)
(defclass json-direct-slot-definition (c2mop:standard-direct-slot-definition)
((json-class :initarg :json :accessor json-class)
(json-name :initarg :json/name :accessor json-name)))
(defclass json-effective-slot-definition (c2mop:standard-effective-slot-definition)
((json-class :initarg :json :accessor json-class)
(json-name :initarg :json/name :accessor json-name)
(json-initarg :accessor json-initarg)))
(defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs)
(if (getf initargs :json)
(find-class 'json-direct-slot-definition)
(call-next-method)))
(defvar *effective-slot-definition-class* nil)
(defmethod c2mop:effective-slot-definition-class ((class json-class) &rest initargs)
(declare (ignore initargs))
;; I'm not sure why we need to use this hack here, but for some reason
;; initargs doesn't contain the slot options like :json and :json/name here
;; like it does in direct-slot-definition-class. So we need another way to
;; know which class to use here.
(or *effective-slot-definition-class* (call-next-method)))
(defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
(if (not (some (lambda (dslot)
(typep dslot 'json-direct-slot-definition))
direct-slots))
(call-next-method)
(let* ((*effective-slot-definition-class* (find-class 'json-effective-slot-definition))
(eslot (call-next-method))
(dslot (first direct-slots)) ; todo be smarter about coalescing these
(initarg (gensym (format nil "json-initarg-~A" name)))) ; todo nicer name
(setf (json-name eslot) (if (slot-boundp dslot 'json-name)
(json-name dslot)
(funcall (slot-name-to-json-name class) name)) ; todo make this less shitty
(json-class eslot) (if (slot-boundp dslot 'json-class)
(canonicalize-class-designator (json-class dslot))
'(t))
(json-initarg eslot) initarg) ; todo nicer name
(push initarg (c2mop:slot-definition-initargs eslot))
eslot)))
(defun json-slots (class)
(remove-if-not (lambda (slot) (typep slot 'json-effective-slot-definition))
(c2mop:class-slots class)))
(defun make-name-initarg-map (class)
"Return a name/initarg map for the JSON slots of `class`.
The result will be a hash table of `{name: (initarg class contained-class)}`.
"
(let* ((slots (json-slots class))
(result (make-hash-table :test #'equal :size (length slots))))
(dolist (slot slots)
(destructuring-bind (c &optional cc) (json-class slot)
(setf (gethash (json-name slot) result)
(list (json-initarg slot) c cc))))
result))
(defun make-slot-name-alist (class)
(mapcar (lambda (slot)
(cons (c2mop:slot-definition-name slot)
(json-name slot)))
(json-slots class)))
(defmethod shared-initialize ((class json-class) slot-names
&rest initargs
&key slot-name-to-json-name unknown-slots
&allow-other-keys)
(apply #'call-next-method class slot-names
(append
(when slot-name-to-json-name ; todo assert length = 1
(list :slot-name-to-json-name (first slot-name-to-json-name)))
(when unknown-slots ; todo assert length = 1
(list :unknown-slots (first unknown-slots)))
initargs)))
(defmethod c2mop:finalize-inheritance :after ((class json-class))
(setf (name-initarg-map class) (make-name-initarg-map class)
(slot-name-alist class) (make-slot-name-alist class)))
;;;; Read ---------------------------------------------------------------------
(defun parse-json-class (class-name class input)
(let ((ch (r input)))
(unless (eql ch #\{)
(e class-name input "expected ~S but got ~S" #\{ ch)))
(skip-whitespace input)
(if (eql (p input) #\})
(progn
(r input)
(make-instance class))
(loop
:with unknown = (unknown-slots class)
:with map = (name-initarg-map class)
:with init = (list)
:for name = (read% 'string nil input)
:for sep = (parse-kv-separator class-name input)
:for (initarg c cc) = (gethash name map)
:do (progn
(if (null initarg)
(ecase unknown
(:discard (read% t nil input))
(:error (e class-name input "got unknown object attribute ~S" name)))
(progn
(push (read% c cc input) init)
(push initarg init)))
(skip-whitespace input)
(let ((ch (r input)))
(case ch
(#\} (loop-finish))
(#\, (skip-whitespace input))
(t (e class-name input "expected ~S or ~S but got ~S." #\} #\, ch)))))
:finally (return (apply #'make-instance class init)))))
(defmethod read% ((class-name symbol) (contained-class null) (input input))
(let ((class (find-class class-name nil)))
(typecase class
(json-class
(c2mop:ensure-finalized class)
(parse-json-class class-name class input))
(null (error "Cannot find class ~S to parse JSON into." class-name))
(t (error "Cannot parse JSON into class ~S because that class is not a ~S"
class-name 'json-class)))))
;;;; Printing -----------------------------------------------------------------
(defmethod print% (thing stream)
(let ((class (class-of thing)))
(if (typep class 'json-class)
(progn
(write-char #\{ stream)
(loop :with first = t
:for (slot . name) :in (slot-name-alist class)
:when (slot-boundp thing slot)
:do (progn (if first
(setf first nil)
(write-char #\, stream))
(print% name stream)
(write-char #\: stream)
(print% (slot-value thing slot) stream)))
(write-char #\} stream))
(error "Don't know how to print object ~S of class ~S as JSON." thing class))))
;;;; API ----------------------------------------------------------------------
(defun canonicalize-class-designator (class-designator)
(flet ((fail () (error "Malformed class designator ~S" class-designator)))
(etypecase class-designator
(cons (destructuring-bind (head a &optional (b nil b?)) class-designator
(ecase head
; (vector foo)
((hash-table vector)
(progn (when b? (fail))
(list head (canonicalize-class-designator a))))
; (or null foo)
(or (progn
(unless b? (fail)) ; must have a second option
(when (eql 'null b) (rotatef a b)) ; sort a/b
(unless (eql 'null a) (fail)) ; no arbitrary ors
(list 'nullable (canonicalize-class-designator b)))))))
(symbol (case class-designator
(vector '(vector (t)))
(hash-table '(hash-table (t)))
(t (list class-designator)))))))
(defun ensure-stream (stream-or-string)
(etypecase stream-or-string
(stream stream-or-string)
(string (make-string-input-stream stream-or-string))))
(defun read (class-designator stream-or-string &optional (eof-error-p t) eof)
(let ((input (make-input :stream (ensure-stream stream-or-string))))
(skip-whitespace input)
(if (eql :eof (p input))
(if eof-error-p
(error 'end-of-file)
eof)
(destructuring-bind (class &optional contained)
(canonicalize-class-designator class-designator)
(read% class contained input)))))
(defun print (object &optional (stream *standard-output*))
(let ((*read-default-float-format* 'double-float)
(*print-base* 10))
(etypecase stream
((or stream (eql t)) (progn (print% object stream)
(values)))
(null (with-output-to-string (s)
(print% object s))))))