Skip to content

Commit

Permalink
add-json-rpc-2.0-support
Browse files Browse the repository at this point in the history 
A large number of changes that provide json-rpc-2.0 support to
cl-json.  Tests are included.

darcs-hash:20100114024858-b37ea-79170f123f878bab89580228742102860b5930a9.gz
  • Loading branch information
@rpgoldman
rpgoldman committed Jan 14, 2010
1 parent b7c9f71 commit 584ea05
Show file tree
Hide file tree
Showing 3 changed files with 164 additions and 124 deletions.
210 changes: 111 additions & 99 deletions src/json-rpc.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -125,41 +125,44 @@ It has three properties:
* id - This must be the same id as the request it is responding to. "
(cond ((equalp *json-rpc-version* +json-rpc-1.1+)
(with-explicit-encoder
(json:encode-json-to-string
`(:object
(:result . ,result)
(:error . ,error)
(:id . ,id)))))
((and (equalp *json-rpc-version* +json-rpc-2.0+)
result)
(when error
(error "Forbidden to have both a JSON-RPC result AND a JSON-RPC error."))
(with-explicit-encoder
(json:encode-json-to-string
`(:object
(:jsonrpc . ,+json-rpc-2.0+)
(:result . ,result)
(:id . ,id)))))
((and (equalp *json-rpc-version* +json-rpc-2.0+)
error)
(unless (and (assoc :code error)
(integerp (cdr (assoc :code error)))
(assoc :message error)
(stringp (cdr (assoc :message error))))
(cerror "Just return it anyway."
"Ill-formed JSON-RPC error, ~a, for version ~a"
error *json-rpc-version*))
(with-explicit-encoder
(json:encode-json-to-string
`(:object
(:jsonrpc . ,+json-rpc-2.0+)
(:error . ,error)
(:id . ,id)))))
(t (error "Ill-formed JSON-RPC response for protocol version ~a." *json-rpc-version*))))
(json:encode-json-to-string
`(:object
(:result . ,result)
(:error . ,error)
(:id . ,id)))))
((equalp *json-rpc-version* +json-rpc-2.0+)
(cond (result
(when error
(error "Forbidden to have both a JSON-RPC result AND a JSON-RPC error."))
(with-explicit-encoder
(json:encode-json-to-string
`(:object
(:jsonrpc . ,+json-rpc-2.0+)
(:result . ,result)
(:id . ,id)))))
(error
(let ((error (cdr error)))
;; check the slots
(unless (and (assoc :code error)
(integerp (cdr (assoc :code error)))
(assoc :message error)
(stringp (cdr (assoc :message error))))
(cerror "Just return it anyway."
"Ill-formed JSON-RPC error, ~a, for version ~a"
error *json-rpc-version*)))
(with-explicit-encoder
(json:encode-json-to-string
`(:object
(:jsonrpc . ,+json-rpc-2.0+)
(:error . ,error)
(:id . ,id)))))
(t
(error "Response must have either result or error."))))
(t (error "Unknown JSON-RPC protocol version ~a." *json-rpc-version*))))


(defun make-json-rpc-error-object-1.1 (message &key code error-object)
"This code is based on the Working Draft 7 August 2006 of Json-rpc 1.1 specification.
"This code is based on the Working Draft 7 August 2006 of Json-rpc 1.1 specification.
http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
"
(let ((eo `(:object
Expand Down Expand Up @@ -191,19 +194,18 @@ It has three properties:
(:service-error -32000)))
(unless (integerp code)
(error "Code attribute of JSON-RPC object must be an integer.")))
(let ((eo `(:object
(:name . "JSONRPCError")
(:code . ,code)
(:message . ,message)))
data-obj)
(let (data-obj)
(when error-object
(push `(:error . ,error-object) data-obj))
(when data
(push `(:data ,data) data-obj))
(when data-obj
(cons ':data data-obj)
(setf eo (cons data-obj eo)))
eo))
(let ((eo `(:object
(:name . "JSONRPCError")
(:code . ,code)
(:message . ,message)
,@(when data-obj
`((:data . (:object ,@data-obj)))))))
eo)))

(defun invoke-rpc (json-source)
"A remote method is invoked by sending a request to a remote service. The request is a single object serialized using JSON.
Expand All @@ -216,67 +218,77 @@ It has three properties:
(json-bind (method params id) json-source
(invoke-rpc-parsed method params id)))

(define-condition json-rpc-call-error (error)
((encapsulated-error
:initarg :error
:reader encapsulated-error
)))


(defun invoke-rpc-parsed (method params &optional id)
(flet ((json-rpc-2.0 ()
(equalp *json-rpc-version* +json-rpc-2.0+)))
(restart-case
(let ((func-type (gethash method *json-rpc-functions*)))
(if func-type
(destructuring-bind (func . type) func-type
(let ((retval (restart-case (apply func params)
(use-value (value)
value)))
explicit-retval)
(when id
;; if there's no id, this is a notification, and no response should be sent
;; [2009/12/30:rpg]
(setf explicit-retval
(encode-json-rpc-value retval type)))
(make-rpc-response :id id :result explicit-retval)))

(when id
(make-rpc-response :id id :error (cond ((json-rpc-2.0)
(make-json-rpc-error-object-2.0
:message (format nil "Procedure ~a not found." method)
:code :method-not-found))
(t
(make-json-rpc-error-object-1.1
(format nil "Procedure ~a not found." method))))))))

(send-error (message &optional code error-object)
:test (lambda (c) (declare (ignore c)) id)
(make-rpc-response :id id
:error
(if (json-rpc-2.0)
(progn
(unless code
(assert code (code)
"Error code is mandatory in JSON-RPC version 2.0."))
(if error-object
(make-json-rpc-error-object-2.0
:message message
:code code
:error-object error-object)
(make-json-rpc-error-object-2.0
:message message
:code code)))
(make-json-rpc-error-object-1.1 message
:code code
:error-object error-object))))
(send-error-object (error-object)
:test (lambda (c) (declare (ignore c)) id)
(make-rpc-response :id id :error error-object))
(send-nothing ()
nil)
(send-internal-error ()
:test (lambda (c) (declare (ignore c)) id)
(make-rpc-response :id id
:error
(if (json-rpc-2.0)
(make-json-rpc-error-object-2.0
:message "Service error"
:code :service-error)
(make-json-rpc-error-object-1.1 "Service error")))))))
(restart-case
(let ((func-type (gethash method *json-rpc-functions*)))
(if func-type
(handler-bind
((error #'(lambda (err)
(error 'json-rpc-call-error :error err))))
(destructuring-bind (func . type) func-type
(let ((retval (restart-case (apply func params)
(use-value (value)
value)))
explicit-retval)
(when id
;; if there's no id, this is a notification, and no response should be sent
;; [2009/12/30:rpg]
(setf explicit-retval
(encode-json-rpc-value retval type)))
(make-rpc-response :id id :result explicit-retval))))

(when id
(make-rpc-response :id id :error (cond ((json-rpc-2.0)
(make-json-rpc-error-object-2.0
:message (format nil "Procedure ~a not found." method)
:code :method-not-found))
(t
(make-json-rpc-error-object-1.1
(format nil "Procedure ~a not found." method))))))))
(send-error (message &optional code error-object)
:test (lambda (c) (declare (ignore c)) id)
(make-rpc-response :id id
:error
(if (json-rpc-2.0)
(progn
(unless code
(assert code (code)
"Error code is mandatory in JSON-RPC version 2.0."))
(if error-object
(make-json-rpc-error-object-2.0
:message message
:code code
:error-object error-object)
(make-json-rpc-error-object-2.0
:message message
:code code)))
(make-json-rpc-error-object-1.1 message
:code code
:error-object error-object))))
(send-error-object (error-object)
:test (lambda (c) (declare (ignore c)) id)
(make-rpc-response :id id :error error-object))
(send-nothing ()
nil)
(send-internal-error ()
:test (lambda (c) (declare (ignore c)) id)
(format t "~&invoking send-internal-error restart.~%")
(make-rpc-response :id id
:error
(if (json-rpc-2.0)
(make-json-rpc-error-object-2.0
:message "Service error"
:code :service-error)
(make-json-rpc-error-object-1.1 "Service error")))))))

(defmacro def-restart (restart-name &rest (params))
`(defun ,restart-name (,@params &optional condition)
Expand Down
3 changes: 3 additions & 0 deletions src/package.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -140,6 +140,9 @@
#:+json-rpc-1.1+
#:+json-rpc-2.0+

;; condition
#:json-rpc-call-error

;; declarations
#:def-json-rpc-encoding
#:defun-json-rpc
Expand Down
75 changes: 50 additions & 25 deletions t/testmisc.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -103,12 +103,17 @@ encoding."
(error "Intentionally raised error.")
x))

(defun json-rpc-2-p (&optional (flag json-rpc:*json-rpc-version*))
(eql (aref flag 0) #\2))

(defun test-json-rpc-helper (method-name)
(with-decoder-simple-list-semantics
(let (result)
(setf result (json-rpc:invoke-rpc
(format nil "{\"method\":\"~a\",\"params\":[1,2],\"id\":999}" method-name)))
(is (string= result "{\"result\":{\"digits\":3,\"letters\":\"three\"},\"error\":null,\"id\":999}")))))
(format nil "{~@[~*\"jsonrpc\":\"2.0\",~]\"method\":\"~a\",\"params\":[1,2],\"id\":999}" (json-rpc-2-p) method-name)))
(is (string= result
(format nil "{~@[~*\"jsonrpc\":\"2.0\",~]\"result\":{\"digits\":3,\"letters\":\"three\"},~@[~*\"error\":null,~]\"id\":999}"
(json-rpc-2-p) (not (json-rpc-2-p))))))))

(defun test-json-rpc-boolean-helper (input-value output-value)
(with-decoder-simple-list-semantics
Expand All @@ -122,18 +127,25 @@ encoding."
(encode-json-to-string input-value)))
(result
(handler-bind
((error #'(lambda (x)
(declare (ignore x))
(invoke-restart 'json-rpc:send-internal-error))))
((json-rpc-call-error #'(lambda (x)
(declare (ignore x))
(invoke-restart 'json-rpc:send-internal-error))))
(json-rpc:invoke-rpc
(format nil "{\"method\":\"fooB\",\"params\":[~a],\"id\":999}" input-encoded)))))
(format nil
"{~@[~*\"jsonrpc\":\"2.0\",~]\"method\":\"fooB\",\"params\":[~a],\"id\":999}"
(json-rpc-2-p) input-encoded)))))
(if error
(let ((res (decode-json-from-string result)))
(is (and (null (cdr (assoc :result res)))
(cdr (assoc :error res)))))
(if (json-rpc-2-p)
;; if there's an error in 2.0, the result must be missing, not null
(is (and (null (assoc :result res))
(cdr (assoc :error res))))
(is (and (null (cdr (assoc :result res)))
(cdr (assoc :error res))))))
(is (string= result
(format nil "{\"result\":~a,\"error\":null,\"id\":999}"
expected)))))))
(format nil "{~@[~*\"jsonrpc\":\"2.0\",~]\"result\":~a,~@[~*\"error\":null,~]\"id\":999}"
(json-rpc-2-p) expected
(not (json-rpc-2-p)))))))))

(defun test-json-rpc-array-helper (input-value output-value)
(with-decoder-simple-list-semantics
Expand All @@ -153,46 +165,59 @@ encoding."
(format nil "~a" x)
999))))
(json-rpc:invoke-rpc
(format nil "{\"method\":\"fooA\",\"params\":[~a],\"id\":999}" input-encoded)))))
(format nil "{~@[~*\"jsonrpc\":\"2.0\",~]\"method\":\"fooA\",\"params\":[~a],\"id\":999}"
(json-rpc-2-p) input-encoded)))))
(if error
(let ((res (decode-json-from-string result)))
(is (and (null (cdr (assoc :result res)))
(cdr (assoc :error res)))))
(is (string= result
(format nil "{\"result\":~a,\"error\":null,\"id\":999}"
expected)))))))

(test test-json-rpc
(format nil "{~@[~*\"jsonrpc\":\"2.0\",~]\"result\":~a,~@[~*\"error\":null,~]\"id\":999}"
(json-rpc-2-p) expected
(not (json-rpc-2-p)))))))))

(defmacro test-json-rpc-both (name &rest body)
(let ((two-oh-name
(intern (concatenate 'string (symbol-name name) "-"
(symbol-name '#:json-rpc-2.0)))))
`(progn
(test ,name
,@body)
(test ,two-oh-name
(let ((json-rpc:*json-rpc-version* json-rpc:+json-rpc-2.0+))
,@body)))))

(test-json-rpc-both test-json-rpc
(test-json-rpc-helper "fooG"))

(test test-json-rpc-explicit
(test-json-rpc-both test-json-rpc-explicit
(test-json-rpc-helper "fooE"))

(test test-json-rpc-streaming
(test-json-rpc-both test-json-rpc-streaming
(test-json-rpc-helper "fooS"))

(test test-json-rpc-boolean-true
(test-json-rpc-both test-json-rpc-boolean-true
(test-json-rpc-boolean-helper t t))

(test test-json-rpc-boolean-false
(test-json-rpc-both test-json-rpc-boolean-false
(test-json-rpc-boolean-helper nil nil))

(test test-json-rpc-boolean-error
(test-json-rpc-both test-json-rpc-boolean-error
(test-json-rpc-boolean-helper :error :error))

(test test-json-rpc-array-simple
(test-json-rpc-both test-json-rpc-array-simple
(test-json-rpc-array-helper (list 1 2 3) (list 1 2 3)))

(test test-json-rpc-array-array
(test-json-rpc-both test-json-rpc-array-array
(test-json-rpc-array-helper #(1 2 3) (list 1 2 3)))

(test test-json-rpc-empty-array
(test-json-rpc-both test-json-rpc-empty-array
(test-json-rpc-array-helper #() #()))

(test test-json-rpc-array-nil
(test-json-rpc-both test-json-rpc-array-nil
(test-json-rpc-array-helper nil #()))

(test test-json-rpc-array-scalar-error
(test-json-rpc-both test-json-rpc-array-scalar-error
(test-json-rpc-array-helper 1 :error))

(test test-json-rpc-unknown-fn
Expand Down

0 comments on commit 584ea05

Please sign in to comment.