# HG changeset patch # User Steve Losh # Date 1597801845 14400 # Node ID 8e500ea0d9ff5b455516f085c341a2746bc4a544 # Parent 24d3163b1f646f7d31def4ded45be4e2521f2179 Add :allow-print and :allow-read These can be useful to restrict reading/printing to make sure you don't accidentally serialize the wrong thing and send an internal data structure out over the wire. diff -r 24d3163b1f64 -r 8e500ea0d9ff .TODO.done --- a/.TODO.done Sat Aug 15 00:27:30 2020 -0400 +++ b/.TODO.done Tue Aug 18 21:50:45 2020 -0400 @@ -1,3 +1,4 @@ +Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5 Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4 Add opaque-json type | id:a1a380eb9782d088693dfb75402b99c2b30cf039 Add size and depth limits | id:ab9b49ec993f1e46c34b9d627549f41cad80609d diff -r 24d3163b1f64 -r 8e500ea0d9ff TODO --- a/TODO Sat Aug 15 00:27:30 2020 -0400 +++ b/TODO Tue Aug 18 21:50:45 2020 -0400 @@ -1,4 +1,4 @@ -Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5 +Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7 Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732 Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8 Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984 diff -r 24d3163b1f64 -r 8e500ea0d9ff src/mop.lisp --- a/src/mop.lisp Sat Aug 15 00:27:30 2020 -0400 +++ b/src/mop.lisp Tue Aug 18 21:50:45 2020 -0400 @@ -13,7 +13,9 @@ :initarg :unknown-slots :initform :discard) (name-initarg-map :accessor name-initarg-map) - (slot-name-alist :accessor slot-name-alist))) + (slot-name-alist :accessor slot-name-alist) + (allow-print :accessor allow-print :initarg :allow-print :initform t) + (allow-read :accessor allow-read :initarg :allow-read :initform t))) (defmethod c2mop:validate-superclass ((class json-class) (superclass standard-class)) t) @@ -89,15 +91,17 @@ (defmethod shared-initialize ((class json-class) slot-names &rest initargs - &key slot-name-to-json-name unknown-slots + &key slot-name-to-json-name unknown-slots allow-print allow-read &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))) + (flet ((arg (initarg args) + (when args ; todo assert length = 1 + (list initarg (first args))))) + (apply #'call-next-method class slot-names + (append (arg :slot-name-to-json-name slot-name-to-json-name) + (arg :unknown-slots unknown-slots) + (arg :allow-read allow-read) + (arg :allow-print allow-print) + initargs)))) (defmethod c2mop:finalize-inheritance :after ((class json-class)) (setf (name-initarg-map class) (make-name-initarg-map class) @@ -106,6 +110,8 @@ ;;;; Read --------------------------------------------------------------------- (defun parse-json-class (class-name class input) + (unless (allow-read class) + (error "Class ~S does not allow reading." class)) (let ((ch (r input))) (unless (eql ch #\{) (e class-name input "expected ~S but got ~S" #\{ ch))) @@ -152,18 +158,21 @@ ;;;; 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)))) + (cond + ((not (typep class 'json-class)) + (error "Don't know how to print object ~S of class ~S as JSON." thing class)) + ((not (allow-print class)) + (error "Class ~S does not allow printing." class)) + (t + (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))))) diff -r 24d3163b1f64 -r 8e500ea0d9ff src/package.lisp --- a/src/package.lisp Sat Aug 15 00:27:30 2020 -0400 +++ b/src/package.lisp Tue Aug 18 21:50:45 2020 -0400 @@ -4,4 +4,8 @@ (:export :read :print - :json-parsing-error :line :column)) + :json-parsing-error :line :column + + :json-class + + )) diff -r 24d3163b1f64 -r 8e500ea0d9ff test/tests.lisp --- a/test/tests.lisp Sat Aug 15 00:27:30 2020 -0400 +++ b/test/tests.lisp Tue Aug 18 21:50:45 2020 -0400 @@ -310,6 +310,33 @@ (signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]"))))) +;;;; Allow Print/Read --------------------------------------------------------- +(defclass foo () + ((id :json number :initarg :id)) + (:metaclass jarl:json-class)) + +(defclass foo/deny-read () + ((id :json number :initarg :id)) + (:metaclass jarl:json-class) + (:allow-read nil)) + +(defclass foo/deny-print () + ((id :json number :initarg :id)) + (:metaclass jarl:json-class) + (:allow-print nil)) + + +(define-test allow-read + (is (= 1 (slot-value (jarl:read 'foo (json "{'id': 1}")) 'id))) + (is (= 1 (slot-value (jarl:read 'foo/deny-print (json "{'id': 1}")) 'id))) + (signals error (jarl:read 'foo/deny-read (json "{'id': 1}")))) + +(define-test allow-print + (is (string= (json "{'id':1}") (jarl:print (make-instance 'foo :id 1) nil))) + (is (string= (json "{'id':1}") (jarl:print (make-instance 'foo/deny-read :id 1) nil))) + (signals error (jarl:print (make-instance 'foo/deny-print :id 1) nil))) + + ;;;; Fuzz Utilities ----------------------------------------------------------- (defparameter *basic-chars* " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")