mirror of https://codeberg.org/cage/tinmop/
526 lines
19 KiB
Common Lisp
526 lines
19 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © 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 [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
|
|
|
|
(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-error-data+ "data" :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 &optional (data nil))
|
|
(list (cons +key-error-code+ code)
|
|
(cons +key-error-message+ message)
|
|
(cons +key-error-data+ data)))
|
|
|
|
(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 unsupported-protocol -32098 "Only protocol version 2.0 is supported"
|
|
:customp t)
|
|
|
|
(defun make-internal-error-message (msg data)
|
|
(make-response-error -32603 (format nil "Internal error: ~a" msg) data))
|
|
|
|
(defun make-failed-function-call-error-message (msg &optional (data nil))
|
|
(make-response-error -32001
|
|
(format nil "Failed function call: ~a" msg)
|
|
data))
|
|
|
|
(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"))
|
|
|
|
(defmacro make-json-rpc-error (code message)
|
|
`(progn
|
|
(assert (< -32000 ,code -32099))
|
|
(error 'json-rpc-error :text ,message :code ,code)))
|
|
|
|
(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 must 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))
|
|
|
|
(defclass rpc-response (identificable)
|
|
((payload
|
|
:initform nil
|
|
:initarg :payload
|
|
:accessor payload)
|
|
(error-response
|
|
:initform nil
|
|
:initarg :error-response
|
|
:accessor error-response)))
|
|
|
|
(defmethod yason:encode ((object rpc-response) &optional (stream *standard-output*))
|
|
(with-accessors ((payload payload)
|
|
(error-response error-response)
|
|
(request-id id)) object
|
|
(yason:with-output (stream)
|
|
(let ((yason:*list-encoder* #'yason:encode-alist)
|
|
(yason:*symbol-encoder* #'yason:encode-symbol-as-lowercase))
|
|
(if error-response
|
|
(yason:encode (list (cons +key-name+ +protocol-version+)
|
|
(cons +key-error+ error-response)
|
|
(cons +key-id+ request-id))
|
|
stream)
|
|
(progn
|
|
(yason:with-object ()
|
|
(yason:with-object-element (+key-name+)
|
|
(yason:encode +protocol-version+ stream))
|
|
(yason:with-object-element (+key-result+)
|
|
(yason:encode payload stream))
|
|
(yason:with-object-element (+key-id+)
|
|
(let ((yason:*list-encoder* #'yason:encode-plist))
|
|
(yason:encode request-id stream))))))))))
|
|
|
|
(defmethod yason:encode ((object rpc-request) &optional (stream *standard-output*))
|
|
(let ((yason:*list-encoder* #'yason:encode-alist))
|
|
(yason:encode (render-as-list object) stream)))
|
|
|
|
(defmethod yason:encode ((object rpc-request-batch) &optional (stream *standard-output*))
|
|
(yason:with-output (stream)
|
|
(yason:with-array ()
|
|
(loop for request in (requests object) do
|
|
(yason:encode-array-element request)))))
|
|
|
|
(defun encode-to-string (object)
|
|
(with-output-to-string (stream)
|
|
(yason:encode object stream)))
|
|
|
|
(defgeneric render-as-list (object))
|
|
|
|
(defmethod render-as-list (object)
|
|
object)
|
|
|
|
(defmethod render-as-list ((object rpc-request-batch))
|
|
(loop for i in (requests object) collect (render-as-list i)))
|
|
|
|
(defmethod render-as-list ((object rpc-response))
|
|
(payload object))
|
|
|
|
(defmethod render-as-list ((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
|
|
:id request-id
|
|
:payload results
|
|
:error-response error-object))
|
|
|
|
(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: expected ~a got ~a for ~a."
|
|
(length (params fun))
|
|
(length (params request))
|
|
(function-id request))))
|
|
|
|
(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
|
|
:transaction-id id
|
|
:code (response-error-code +error-invalid-request+)
|
|
:text (response-error-message +error-invalid-request+)))
|
|
((not (supported-version-p protocol-version))
|
|
(error 'json-rpc-error
|
|
:transaction-id id
|
|
:code (response-error-code +error-unsupported-protocol+)
|
|
:text (response-error-message +error-unsupported-protocol+)))
|
|
((not (listp params))
|
|
(error 'json-rpc-error
|
|
:transaction-id id
|
|
:code (response-error-code +error-invalid-request+)
|
|
:text (response-error-message +error-invalid-request+)))
|
|
(t
|
|
(values method id params))))))
|
|
|
|
(defun maybe-log-message (m)
|
|
(declare (ignorable m))
|
|
#+debug-json-rpc
|
|
(misc:dbg m))
|
|
|
|
(defun elaborate-single-request (request)
|
|
(flet ((make-rpc-error (e id &optional (data nil))
|
|
(maybe-log-message (format nil "jsonrpc request failed: ~a" e))
|
|
(make-response nil
|
|
(or (transaction-id e)
|
|
id)
|
|
:error-object (make-response-error (or (code e)
|
|
(response-error-code +error-invalid-request+))
|
|
(text e)
|
|
data)))
|
|
(make-internal-error (e &optional (data nil))
|
|
(make-response nil
|
|
nil
|
|
:error-object (make-internal-error-message (format nil "~a" e)
|
|
data)))
|
|
(make-failed-function-error (e id &optional (data nil))
|
|
(make-response nil
|
|
id
|
|
:error-object (make-failed-function-call-error-message (format nil
|
|
"[~a] ~a"
|
|
request
|
|
e)
|
|
data))))
|
|
(handler-case
|
|
(multiple-value-bind (method id params)
|
|
(displace-single-request request)
|
|
(handler-case
|
|
(let* ((request (apply #'make-request method id params))
|
|
(elaborated (call-function request)))
|
|
(maybe-log-message (format nil
|
|
"jsonrpc request ~s results ~s"
|
|
request
|
|
elaborated))
|
|
(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-rpc-error e id request))
|
|
(error (e)
|
|
(maybe-log-message (format nil "jsonrpc request failed: ~a" e))
|
|
(make-failed-function-error e id request))))
|
|
(json-rpc-error (e)
|
|
(make-rpc-error e nil request))
|
|
(error (e)
|
|
(maybe-log-message (format nil "jsonrpc request failed with internal error!: ~a" e))
|
|
(make-internal-error e request)))))
|
|
|
|
(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)
|
|
(maybe-log-message (format nil "jsonrpc2 raw request~a" raw-request))
|
|
(let ((decoded (yason:parse stream :object-as :alist)))
|
|
(maybe-log-message (format nil "decoded request ~a~%" decoded))
|
|
(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)))
|
|
(let ((results (elaborate-single-request decoded)))
|
|
results))))
|
|
(error (e)
|
|
(maybe-log-message (format nil "request parse error: ~a" e))
|
|
(make-response nil nil :error-object +error-parse+))))
|
|
|
|
(defgeneric make-json-extract-key (object))
|
|
|
|
(defmethod make-json-extract-key ((object string))
|
|
(make-json-extract-key (make-keyword (string-upcase object))))
|
|
|
|
(defmethod make-json-extract-key ((object symbol))
|
|
object)
|
|
|
|
(defun extract-results (response)
|
|
(getf response (make-json-extract-key +key-result+)))
|
|
|
|
(defun error-response-p (response)
|
|
(getf response (make-json-extract-key +key-error+)))
|
|
|
|
(defun extract-error (response)
|
|
(let ((error-field (getf response (make-json-extract-key +key-error+))))
|
|
(values (getf error-field (make-json-extract-key +key-id+))
|
|
(getf error-field (make-json-extract-key +key-error-message+))
|
|
(getf error-field (make-json-extract-key +key-error-code+))
|
|
(getf error-field (make-json-extract-key +key-error-data+)))))
|