From 53379fdd37663b87cf295421d58a9296553db19c Mon Sep 17 00:00:00 2001 From: cage Date: Sat, 17 Dec 2022 14:41:25 +0100 Subject: [PATCH] - added a json-rpc2 implementation. --- src/json-rpc2.lisp | 441 ++++++++++++++++++++++++++++++++++ src/package.lisp | 21 ++ src/tests/jsonrpc2-tests.lisp | 180 ++++++++++++++ src/tests/package.lisp | 9 + tinmop.asd | 4 +- 5 files changed, 654 insertions(+), 1 deletion(-) create mode 100644 src/json-rpc2.lisp create mode 100644 src/tests/jsonrpc2-tests.lisp diff --git a/src/json-rpc2.lisp b/src/json-rpc2.lisp new file mode 100644 index 0000000..21d4680 --- /dev/null +++ b/src/json-rpc2.lisp @@ -0,0 +1,441 @@ +;; fulci: a program to organize your movies collection +;; Copyright (C) 2019 cage + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(in-package :json-rpc2) + +(define-constant +protocol-version+ "2.0" :test #'string=) + +(define-constant +key-name+ "jsonrpc" :test #'string=) + +(define-constant +key-method+ "method" :test #'string=) + +(define-constant +key-params+ "params" :test #'string=) + +(define-constant +key-id+ "id" :test #'string=) + +(define-constant +key-error+ "error" :test #'string=) + +(define-constant +key-error-code+ "code" :test #'string=) + +(define-constant +key-error-message+ "message" :test #'string=) + +(define-constant +key-result+ "result" :test #'string=) + +(define-constant +error-reserved-min+ -32099 :test #'=) + +(define-constant +error-reserved-max+ -32000 :test #'=) + +(define-constant +error-reserved-method-name+ "^rpc\\." :test #'string=) + +(defun invalid-method-name-p (n) + (cl-ppcre:scan +error-reserved-method-name+ n)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-response-error (code message) + (list (cons +key-error-code+ code) + (cons +key-error-message+ message))) + + (defun response-error-code (err) + (cdar err)) + + (defun response-error-message (err) + (cdadr err))) + +(defmacro define-error-code (name number message &key (customp nil)) + (if (and customp + (not (<= +error-reserved-min+ number +error-reserved-max+))) + (error (format nil "implementation defined error bust be between ~a and ~a" + +error-reserved-min+ +error-reserved-max+)) + `(define-constant ,(misc:format-fn-symbol t "+error-~a+" name) + (make-response-error ,number ,message) + :test #'equalp))) + +(define-error-code parse -32700 "Parse error") + +(define-error-code invalid-request -32600 "Invalid Request") + +(define-error-code method-not-found -32601 "Method not found") + +(define-error-code invalid-params -32602 "Invalid params") + +(define-error-code internal-error -32603 "Internal error") + +(define-error-code unsupported-protocol -32098 "Only protocol version 2.0 is supported" + :customp t) + +(defclass function-param () + ((name + :initarg :name + :initform "" + :accessor name + :type string) + (pos + :initarg :pos + :initform -1 + :accessor pos + :type integer))) + +(defmethod print-object ((object function-param) stream) + (format stream "[~s @ ~a]" (name object) (pos object))) + +(defparameter *request-id* 1) + +(defun generate-request-id () + (incf *request-id*) + *request-id*) + +(define-condition json-rpc-error (error) + ((transaction-id + :initform nil + :initarg :transaction-id + :reader transaction-id) + (code + :initarg :code + :reader code) + (text + :initarg :text + :reader text)) + (:report (lambda (condition stream) + (format stream "~a" (text condition)))) + (:documentation "Error for all jsonrpc related problems")) + +(defparameter *function-db* '()) + +(defun make-fun-params (name position) + (cond + ((not (stringp name)) + (error 'json-rpc-error + :text (format nil "Name of a function parameter must be a string not ~a" name))) + ((or (not (integerp position)) + (< position 0)) + (error 'json-rpc-error + :text (format nil + "The position of a function parameter must be positive integer not ~a" + position))) + (t + (make-instance 'function-param :name name :pos position)))) + +(defun find-function (sym) + (conditions:with-default-on-error (nil) + (symbol-function sym))) + +(defun register-function (function-id fun &optional params) + (let* ((actual-params (loop for param in params collect + (make-fun-params (car param) + (cdr param)))) + (fun (make-instance 'rpc-function + :function-id function-id + :fun-symbol fun + :params actual-params))) + (push fun *function-db*))) + +(defun compare-functions-fn (function-id) + (lambda (a) + (string= function-id (function-id a)))) + +(defun unregister-function (function-id) + (setf *function-db* (remove-if (compare-functions-fn function-id) *function-db*))) + +(defun lookup-function (function-id) + (find-if (compare-functions-fn function-id) *function-db*)) + +(defclass identificable () + ((id + :initarg :id + :initform -1 + :accessor id + :type integer))) + +(defclass fun-symbol-box () + ((fun-symbol + :initarg :fun-symbol + :initform nil + :accessor fun-symbol + :type symbol))) + +(defmethod initialize-instance :after ((object fun-symbol-box) &key &allow-other-keys) + (with-accessors ((fun-symbol fun-symbol)) object + (cond + ((not (symbolp fun-symbol)) + (error 'json-rpc-error + :text (format nil "function symbol of a function be a symbol not ~a" + fun-symbol))) + ((not (find-function fun-symbol)) + (error 'json-rpc-error + :text (format nil "~a is not a function" fun-symbol)))))) + +(defclass fun-box () + ((function-id + :initarg :function-id + :initform "" + :accessor function-id + :type string) + (params + :initarg :params + :initform '() + :accessor params + :type list))) + +(defmethod initialize-instance :after ((object fun-box) &key &allow-other-keys) + (with-accessors ((function-id function-id)) object + (cond + ((not (stringp function-id)) + (error 'json-rpc-error + :text (format nil "ID of a function must be a string not ~a" function-id))) + ((invalid-method-name-p function-id) + (error 'json-rpc-error + :text (format nil + "function ID invalid, starts with a reserved prefix ~s" + +error-reserved-method-name+)))))) + +(defmethod print-object ((object fun-box) stream) + (format stream "function-id: ~s params ~s" (function-id object) (params object))) + +(defclass rpc-function (fun-symbol-box fun-box) ()) + +(defmethod print-object ((object rpc-function) stream) + (print-unreadable-object (object stream :type t) + (format stream "symbol ~s " (fun-symbol object)) + (call-next-method))) + +(defclass rpc-request (fun-box identificable) ()) + +(defclass rpc-request-batch () + ((requests + :initform '() + :initarg :requests + :accessor requests))) + +(defun make-batch (&rest requests) + (make-instance 'rpc-request-batch :requests requests)) + +(defun %make-request (method id &rest params) + (let ((req (make-instance 'rpc-request + :function-id method + :id id + :params params))) + req)) + +(defun make-request (method id &rest params) + (apply #'%make-request method id params)) + +(defun make-request* (method id param) + (if (typep param 'proper-list) + (apply #'%make-request method id param) + (apply #'%make-request method id (list param)))) + +(defun make-notification (method &rest params) + (apply #'%make-request method nil params)) + +(defun make-notification* (method params) + (apply #'%make-request method nil params)) + +(defgeneric jsonify (object)) + +(defclass rpc-response () + ((payload + :initform nil + :initarg :payload + :accessor payload))) + +(defmethod jsonify ((object rpc-response)) + (with-accessors ((payload payload)) object + (with-output-to-string (stream) + (yason:with-output (stream) + (let ((yason:*list-encoder* #'yason:encode-alist)) + (yason:encode-alist (render-flat payload))))))) + +(defmethod jsonify ((object rpc-request)) + (with-output-to-string (stream) + (let ((yason:*list-encoder* #'yason:encode-alist)) + (yason:encode (render-flat object) stream)))) + +(defmethod jsonify ((object rpc-request-batch)) + (with-output-to-string (stream) + (yason:with-output (stream) + (yason:with-array () + (loop for request in (requests object) do + (let ((yason:*list-encoder* #'yason:encode-alist)) + (yason:encode-array-element (render-flat request)))))))) + +(defmethod jsonify ((object (eql nil))) + nil) + +(defmethod jsonify ((object list)) + (with-output-to-string (stream) + (let ((yason:*list-encoder* #'yason:encode-alist)) + (yason:with-output (stream) + (yason:with-array () + (loop for element in object do + (yason:encode-array-element (render-flat element)))))))) + +(defgeneric render-flat (object)) + +(defmethod render-flat (object) + object) + +(defmethod render-flat ((object rpc-request-batch)) + (loop for i in (requests object) collect (render-flat i))) + +(defmethod render-flat ((object rpc-response)) + (payload object)) + +(defmethod render-flat ((object rpc-request)) + (with-accessors ((id id) + (function-id function-id) + (params params)) object + (let ((default (list (cons +key-name+ +protocol-version+) + (cons +key-method+ function-id)))) + (when (not (null (first params))) + (setf default (append default (list (cons +key-params+ params))))) + (if id + (append default + (list (cons +key-id+ id))) + default)))) + +(defun make-response (results request-id &key (error-object nil)) + (make-instance 'rpc-response :payload + (if error-object + (list (cons +key-name+ +protocol-version+) + (cons +key-error+ error-object) + (cons +key-id+ request-id)) + (list (cons +key-name+ +protocol-version+) + (cons +key-result+ results) + (cons +key-id+ request-id))))) + +(defun supported-version-p (v) + (and v + (stringp v) + (string= v +protocol-version+))) + +(defun called-by-name-p (fun params) + (let ((names (loop for i in params when (consp i) collect (car i))) + (template-names (loop for i in (params fun) collect (name i)))) + (and names + (every (lambda (a) (or (symbolp a) (stringp a))) names) + (null (set-difference names template-names :test #'string-equal))))) + +(defun call-function (request) + (flet ((call-fun (fn params) + (apply (symbol-function (fun-symbol fn)) params))) + (let ((fun (lookup-function (function-id request)))) + (cond + ((not fun) + (error 'json-rpc-error + :code (response-error-code +error-method-not-found+) + :transaction-id (id request) + :text (format nil + "~a: ~s" + (response-error-message +error-method-not-found+) + (function-id request)))) + ((/= (length (params request)) + (length (params fun))) + (error 'json-rpc-error + :code (response-error-code +error-invalid-params+) + :transaction-id (id request) + :text (format nil + "Number of parameters (arity) not compatible with function"))) + (t + (let* ((params (params request)) + (called-by-name-p (called-by-name-p fun params))) + (if called-by-name-p + (let ((params-list (make-list (length (params fun))))) + (loop for p in (params fun) do + (let* ((param-name (name p)) + (param-pos (pos p)) + (param-value (cdr (assoc param-name params + :test #'string-equal)))) + (setf (elt params-list param-pos) param-value))) + (call-fun fun params-list)) + (call-fun fun params)))))))) + +(defun displace-single-request (request) + (flet ((lookup (k) + (and (consp request) + (every #'consp request) + (cdr (assoc k request :test #'string-equal))))) + (let ((protocol-version (lookup +key-name+)) + (method (lookup +key-method+)) + (params (lookup +key-params+)) + (id (lookup +key-id+))) + (cond + ((null protocol-version) + (error 'json-rpc-error + :code (response-error-code +error-invalid-request+) + :text (response-error-message +error-invalid-request+))) + ((not (supported-version-p protocol-version)) + (error 'json-rpc-error + :code (response-error-code +error-unsupported-protocol+) + :text (response-error-message +error-unsupported-protocol+))) + ((not (listp params)) + (error 'json-rpc-error + :code (response-error-code +error-invalid-request+) + :text (response-error-message +error-invalid-request+))) + (t + (values method id params)))))) + +(defun elaborate-single-request (request) + (handler-case + (multiple-value-bind (method id params) + (displace-single-request request) + (let* ((request (apply #'make-request method id params)) + (elaborated (call-function request))) + (when id + ;; if id is null is a notification (i.e. the client + ;; does not care about an answer) + (make-response elaborated id :error-object nil)))) + (json-rpc-error (e) + (make-response nil + (transaction-id e) + :error-object + (make-response-error (or (code e) + (response-error-code +error-invalid-request+)) + (text e)))) + (error () + (make-response nil nil :error-object +error-internal-error+)))) + +(defun likely-not-batch-p (request) + (and (every (lambda (a) (and (consp a) + (car a) + (cdr a))) + request) + (assoc +key-name+ request :test #'string-equal) + (assoc +key-method+ request :test #'string-equal) + (assoc +key-params+ request :test #'string-equal))) + +(defun request-batch-p (request) + (handler-case + (progn + (displace-single-request request) + nil) + (json-rpc-error () + (if (likely-not-batch-p request) + nil + t)) + (error () t))) + +(defun elaborate-request (raw-request) + (handler-case + (with-input-from-string (stream raw-request) + (let ((decoded (yason:parse stream :object-as :alist))) + (if (request-batch-p decoded) + (if (null decoded) + (elaborate-single-request decoded) ;; will build an error response + (remove-if #'null + (mapcar #'elaborate-single-request decoded))) + (elaborate-single-request decoded)))) + (error () + (make-response nil nil :error-object +error-parse+)))) diff --git a/src/package.lisp b/src/package.lisp index 9c71245..8d0caec 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -3005,6 +3005,27 @@ :load-sys-module :load-module)) +(defpackage :json-rpc2 + (:use :cl + :alexandria + :yason) + (:export + :generate-request-id + :*function-db* + :register-function + :unregister-function + :make-request + :make-request* + :make-notification + :make-notification* + :make-batch + :jsonify + :json-rpc-error + :elaborate-request + :transaction-id + :code + :text)) + (defpackage :scripts (:use :cl diff --git a/src/tests/jsonrpc2-tests.lisp b/src/tests/jsonrpc2-tests.lisp new file mode 100644 index 0000000..5eaeee5 --- /dev/null +++ b/src/tests/jsonrpc2-tests.lisp @@ -0,0 +1,180 @@ +;; fulci: a program to organize your movies collection +;; Copyright (C) 2019 cage + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(in-package :jsonrpc2-tests) + +(defsuite jsonrpc-suite (all-suite)) + +(defun dummy-update (&rest params) + (mapcar #'1+ params)) + +(defmacro prepare-rpc (&body body) + `(let ((*function-db* '())) + (register-function "add" '+ (list (cons "a" 0) (cons "b" 1))) + (register-function "subtract" '- (list (cons "subtrahend" 1) + (cons "minuend" 0))) + (register-function "update" 'dummy-update (list (cons "values0" 0) + (cons "values1" 1) + (cons "values2" 2) + (cons "values3" 3) + (cons "values4" 4))) + (register-function "notify_sum" '+ (list (cons "values0" 0) + (cons "values1" 1) + (cons "values2" 2))) + (register-function "notify_hello" '+ (list (cons "values0" 0))) + ,@body)) + +(deftest test-simple (jsonrpc-suite) + (prepare-rpc + (assert-equality #'string= + "{\"jsonrpc\":\"2.0\",\"result\":30,\"id\":1}" + (jsonify (elaborate-request (jsonify (make-request "add" + 1 + '("b" . 10) + '("a" . 20)))))))) + +(defun transaction-test (req expected-req expected-response &optional (show-json-p nil)) + (prepare-rpc + (let* ((json-req (jsonify req)) + (json-resp (jsonify (elaborate-request json-req)))) + (when show-json-p + (format t "~%~a~%~a~%" json-req json-resp)) + (assert-equality #'string= expected-req json-req) + (assert-equality #'string= expected-response json-resp)))) + +(deftest test-sub-positional (jsonrpc-suite) + (transaction-test (make-request "subtract" 1 42 23) + "{\"jsonrpc\":\"2.0\",\"method\":\"subtract\",\"params\":[42,23],\"id\":1}" + "{\"jsonrpc\":\"2.0\",\"result\":19,\"id\":1}")) + +(deftest test-sub-positional-2 (jsonrpc-suite) + (transaction-test (make-request "subtract" 2 23 42) + "{\"jsonrpc\":\"2.0\",\"method\":\"subtract\",\"params\":[23,42],\"id\":2}" + "{\"jsonrpc\":\"2.0\",\"result\":-19,\"id\":2}")) + +(deftest test-sub-named (jsonrpc-suite) + (transaction-test (make-request "subtract" 3 (cons "subtrahend" 23) + (cons "minuend" 42)) + (strcat "{\"jsonrpc\":\"2.0\",\"method\":\"subtract\"," + "\"params\":{\"subtrahend\":23,\"minuend\":42},\"id\":3}") + "{\"jsonrpc\":\"2.0\",\"result\":19,\"id\":3}")) + +(deftest test-sub-named-2 (jsonrpc-suite) + (transaction-test (make-request "subtract" 4 + (cons "minuend" 42) + (cons "subtrahend" 23)) + (strcat "{\"jsonrpc\":\"2.0\",\"method\":\"subtract\"," + "\"params\":{\"minuend\":42,\"subtrahend\":23},\"id\":4}") + "{\"jsonrpc\":\"2.0\",\"result\":19,\"id\":4}")) + +(deftest test-notifications (jsonrpc-suite) + (transaction-test (make-notification* "update" '(1 2 3 4 5)) + "{\"jsonrpc\":\"2.0\",\"method\":\"update\",\"params\":[1,2,3,4,5]}" + nil)) + +(deftest test-non-existent-method (jsonrpc-suite) + (transaction-test (make-request "foobar" 1) + "{\"jsonrpc\":\"2.0\",\"method\":\"foobar\",\"id\":1}" + (strcat "{\"jsonrpc\":\"2.0\"," + "\"error\":{\"code\":-32601," + "\"message\":\"Method not found: \\\"foobar\\\"\"},\"id\":1}"))) + +(deftest test-invalid-json (jsonrpc-suite) + (let* ((json-req "{\"jsonrpc\": \"2.0\", \"method\": \"foobar, \"params\": \"bar\", \"baz]") + (json-resp (jsonify (elaborate-request json-req)))) + (assert-true + (string= json-resp + (strcat "{\"jsonrpc\":\"2.0\",\"error\":{\"code\":-32700," + "\"message\":\"Parse error\"},\"id\":null}"))))) + +(deftest test-invalid-request (jsonrpc-suite) + (let* ((json-req "{\"jsonrpc\": \"2.0\", \"method\": 1, \"params\": \"bar\"}") + (json-resp (jsonify (elaborate-request json-req)))) + (assert-true + (string= json-resp + (strcat "{\"jsonrpc\":\"2.0\",\"error\":" + "{\"code\":-32600,\"message\":\"Invalid Request\"},\"id\":null}"))))) + +(deftest test-batch (jsonrpc-suite) + (prepare-rpc + (let ((req (make-batch (make-request "add" + 2 + '("b" . 10) + '("a" . 20)) + (make-request "foo" 1 1 2) + (make-request "add" 1 1 2))) + (expected (strcat "[" + "{\"jsonrpc\":\"2.0\",\"result\":30,\"id\":2}," + "{\"jsonrpc\":\"2.0\",\"error\":{\"code\":-32601," + "\"message\":\"Method not found: \\\"foo\\\"\"},\"id\":1}," + "{\"jsonrpc\":\"2.0\",\"result\":3,\"id\":1}" + "]"))) + (assert-equality #'string= + expected + (jsonify (elaborate-request (jsonify req))))))) + +(deftest test-batch-json-invalid (jsonrpc-suite) + (let* ((json-req (strcat "[" + "{\"jsonrpc\": \"2.0\", \"method\": \"sum\", \"params\":" + "[1,2,4], \"id\": \"1\"}," + "{\"jsonrpc\": \"2.0\", \"method\"" + "]")) + (json-resp (jsonify (elaborate-request json-req)))) + (assert-true + (string= json-resp + (strcat "{\"jsonrpc\":\"2.0\",\"error\":" + "{\"code\":-32700,\"message\":\"Parse error\"},\"id\":null}"))))) + +(deftest test-batch-empty-array (jsonrpc-suite) + (let* ((json-req "[]") + (json-resp (jsonify (elaborate-request json-req)))) + (assert-true + (string= json-resp + (strcat "{\"jsonrpc\":\"2.0\",\"error\":" + "{\"code\":-32600,\"message\":\"Invalid Request\"},\"id\":null}"))))) + +(deftest test-batch-invalid (jsonrpc-suite) + (let* ((json-req "[1]") + (json-resp (jsonify (elaborate-request json-req)))) + (assert-true + (string= json-resp + (strcat "[" + "{\"jsonrpc\":\"2.0\",\"error\":" + "{\"code\":-32600,\"message\":\"Invalid Request\"},\"id\":null}" + "]"))))) + +(deftest test-batch-invalid-2 (jsonrpc-suite) + (let* ((json-req "[1, 2, 3]") + (json-resp (jsonify (elaborate-request json-req)))) + (assert-true + (string= json-resp + (strcat "[" + "{\"jsonrpc\":\"2.0\",\"error\":" + "{\"code\":-32600,\"message\":\"Invalid Request\"},\"id\":null}," + "{\"jsonrpc\":\"2.0\",\"error\":" + "{\"code\":-32600,\"message\":\"Invalid Request\"},\"id\":null}," + "{\"jsonrpc\":\"2.0\",\"error\":{\"code\":" + "-32600,\"message\":\"Invalid Request\"},\"id\":null}" + "]"))))) + +(deftest test-batch-notification (jsonrpc-suite) + (transaction-test (make-batch (make-notification "notify_sum" 1 2 4) + (make-notification "notify_hello" 7)) + (strcat "[" + "{\"jsonrpc\":\"2.0\",\"method\":\"notify_sum\",\"params\":[1,2,4]}," + "{\"jsonrpc\":\"2.0\",\"method\":\"notify_hello\",\"params\":[7]}" + "]") + nil)) diff --git a/src/tests/package.lisp b/src/tests/package.lisp index af70668..83d4159 100644 --- a/src/tests/package.lisp +++ b/src/tests/package.lisp @@ -126,3 +126,12 @@ :kami :all-tests) (:export)) + +(defpackage :jsonrpc2-tests + (:use :cl + :clunit + :misc + :text-utils + :json-rpc2 + :all-tests) + (:export)) diff --git a/tinmop.asd b/tinmop.asd index 008c9dd..735ac9d 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -144,6 +144,7 @@ (:file "ui-goodies") (:file "scheduled-events") (:file "modules") + (:file "json-rpc2") (:file "main") (:module tests :components ((:file "package") @@ -159,7 +160,8 @@ (:file "gemini-parser-tests") (:file "program-events-tests") (:file "x509-tests") - (:file "idn-tests"))))) + (:file "idn-tests") + (:file "jsonrpc2-tests"))))) ;;(push :debug-mode *features*) ;;(push :debug-gemini-request *features*)