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.
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Tue, 18 Aug 2020 21:50:45 -0400 |
| parents |
24d3163b1f64
|
| children |
c9eb52bb4d0a
|
| branches/tags |
(none) |
| files |
.TODO.done TODO src/mop.lisp src/package.lisp test/tests.lisp |
Changes
--- 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
--- 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
--- 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)))))
--- 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
+
+ ))
--- 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-_,'[]{}+=")