├── .travis.yml ├── jsonrpc.asd ├── tests ├── transport │ ├── tcp.lisp │ ├── websocket.lisp │ └── stdio.lisp └── request-response.lisp ├── README.markdown ├── main.lisp ├── errors.lisp ├── utils.lisp ├── transport ├── interface.lisp ├── stdio.lisp ├── websocket.lisp └── tcp.lisp ├── mapper.lisp ├── request-response.lisp ├── connection.lisp └── class.lisp /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | env: 5 | global: 6 | - PATH=~/.roswell/bin:$PATH 7 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 8 | - COVERAGE_EXCLUDE=tests 9 | matrix: 10 | - LISP=sbcl-bin COVERALLS=true 11 | - LISP=ccl-bin 12 | 13 | install: 14 | # Roswell 15 | - curl -L https://raw.githubusercontent.com/roswell/roswell/release/scripts/install-for-ci.sh | sh 16 | - ros install Shinmera/dissect 17 | - ros install fukamachi/rove 18 | 19 | script: 20 | - rove jsonrpc.asd 21 | -------------------------------------------------------------------------------- /jsonrpc.asd: -------------------------------------------------------------------------------- 1 | (defsystem "jsonrpc" 2 | :class :package-inferred-system 3 | :version "0.3.2" 4 | :author "Eitaro Fukamachi" 5 | :license "BSD 2-Clause" 6 | :description "JSON-RPC 2.0 server/client implementation" 7 | :depends-on ("jsonrpc/main") 8 | :in-order-to ((test-op (test-op "jsonrpc/tests")))) 9 | 10 | (asdf:register-system-packages "clack-handler-hunchentoot" '(#:clack.handler.hunchentoot)) 11 | 12 | (defsystem "jsonrpc/tests" 13 | :class :package-inferred-system 14 | :depends-on ("rove" 15 | "jsonrpc/tests/request-response" 16 | "jsonrpc/tests/transport/tcp" 17 | "jsonrpc/tests/transport/stdio" 18 | "jsonrpc/tests/transport/websocket") 19 | :perform (test-op (o c) (symbol-call :rove '#:run c))) 20 | -------------------------------------------------------------------------------- /tests/transport/tcp.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/tests/transport/tcp 3 | (:use #:cl 4 | #:rove 5 | #:jsonrpc) 6 | (:shadowing-import-from #:rove 7 | #:*debug-on-error*) 8 | (:import-from #:jsonrpc/transport/tcp) 9 | (:import-from #:jsonrpc/utils #:destroy-thread*) 10 | (:import-from #:bordeaux-threads)) 11 | (in-package #:jsonrpc/tests/transport/tcp) 12 | 13 | (deftest tcp-server 14 | (let ((server-thread 15 | (bt:make-thread 16 | (lambda () 17 | (let ((server (jsonrpc:make-server))) 18 | (jsonrpc:expose server "sum" (lambda (args) (reduce #'+ args))) 19 | (jsonrpc:server-listen server :port 50879 :mode :tcp))))) 20 | (client (jsonrpc:make-client))) 21 | 22 | (unwind-protect 23 | (progn 24 | (sleep 0.5) 25 | (jsonrpc:client-connect client :url "http://127.0.0.1:50879" :mode :tcp) 26 | (ok (= (jsonrpc:call client "sum" '(10 20)) 30))) 27 | (destroy-thread* server-thread) 28 | (jsonrpc:client-disconnect client)))) 29 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # jsonrpc 2 | 3 | [![Quicklisp dist](http://quickdocs.org/badge/jsonrpc.svg)](http://quickdocs.org/jsonrpc/) 4 | [![Build Status](https://travis-ci.org/fukamachi/jsonrpc.svg?branch=master)](https://travis-ci.org/fukamachi/jsonrpc) 5 | [![Coverage Status](https://coveralls.io/repos/fukamachi/jsonrpc/badge.svg?branch=master)](https://coveralls.io/r/fukamachi/jsonrpc) 6 | 7 | JSON-RPC 2.0 server/client for Common Lisp. 8 | 9 | ## Usage 10 | 11 | ```common-lisp 12 | ;; server 13 | (defvar *server* (jsonrpc:make-server)) 14 | (jsonrpc:expose *server* "sum" (lambda (args) (reduce #'+ args))) 15 | 16 | (jsonrpc:server-listen *server* :port 50879 :mode :tcp) 17 | ``` 18 | 19 | ```common-lisp 20 | ;; client 21 | (defvar *client* (jsonrpc:make-client)) 22 | (jsonrpc:client-connect *client* :url "http://127.0.0.1:50879" :mode :tcp) 23 | (jsonrpc:call *client* "sum" '(10 20)) 24 | ;=> 30 25 | 26 | ;; Calling with :timeout option 27 | (jsonrpc:call *client* "sum" '(10 20) :timeout 1.0) 28 | ;=> 30 29 | ``` 30 | 31 | To invoke an interactive debugger on any errors in your handlers, set `jsonrpc:*debug-on-error*` to `t`. 32 | 33 | ## Experimental features (only for Server) 34 | 35 | - broadcast 36 | - multicall-async 37 | 38 | ## Author 39 | 40 | * Eitaro Fukamachi (e.arrows@gmail.com) 41 | 42 | ## Copyright 43 | 44 | Copyright (c) 2016 Eitaro Fukamachi (e.arrows@gmail.com) 45 | 46 | ## License 47 | 48 | Licensed under the BSD 2-Clause License. 49 | -------------------------------------------------------------------------------- /tests/transport/websocket.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/tests/transport/websocket 3 | (:use #:cl 4 | #:rove 5 | #:jsonrpc) 6 | (:shadowing-import-from #:rove 7 | #:*debug-on-error*) 8 | (:import-from #:jsonrpc/utils #:destroy-thread*) 9 | (:import-from #:jsonrpc/transport/websocket) 10 | (:import-from #:bordeaux-threads)) 11 | (in-package #:jsonrpc/tests/transport/websocket) 12 | 13 | (defun server-running-p (port) 14 | (handler-case (let ((socket (usocket:socket-connect "127.0.0.1" port))) 15 | (usocket:socket-close socket) 16 | t) 17 | (usocket:connection-refused-error () nil))) 18 | 19 | (deftest websocket-server 20 | (let ((server-thread 21 | (bt:make-thread 22 | (lambda () 23 | (let ((server (jsonrpc:make-server))) 24 | (jsonrpc:expose server "sum" (lambda (args) (reduce #'+ args))) 25 | (jsonrpc:server-listen server :port 50879 :mode :websocket))))) 26 | (client (jsonrpc:make-client))) 27 | 28 | (unwind-protect 29 | (progn 30 | (sleep 0.5) 31 | (loop until (server-running-p 50879) 32 | do (sleep 0.1)) 33 | (jsonrpc:client-connect client :url "ws://127.0.0.1:50879" :mode :websocket) 34 | (ok (= (jsonrpc:call client "sum" '(10 20)) 30))) 35 | (destroy-thread* server-thread) 36 | (jsonrpc:client-disconnect client)))) 37 | -------------------------------------------------------------------------------- /main.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc 3 | (:nicknames #:jsonrpc/main) 4 | (:use #:cl 5 | #:jsonrpc/request-response 6 | #:jsonrpc/transport/interface 7 | #:jsonrpc/class 8 | #:jsonrpc/errors) 9 | (:export 10 | ;; from request-response 11 | #:request 12 | #:response 13 | #:make-request 14 | #:make-response 15 | #:request-method 16 | #:request-params 17 | #:request-id 18 | #:response-error 19 | #:response-result 20 | #:response-id 21 | #:parse-message 22 | 23 | ;; from transports 24 | #:transport 25 | #:send-message 26 | #:receive-message 27 | 28 | ;; from class 29 | #:*default-timeout* 30 | #:server 31 | #:client 32 | #:server-listen 33 | #:client-connect 34 | #:client-disconnect 35 | #:expose 36 | #:register-method 37 | #:clear-methods 38 | #:dispatch 39 | #:call-to 40 | #:call-async-to 41 | #:notify-to 42 | #:call 43 | #:call-async 44 | #:notify 45 | #:notify-async 46 | #:broadcast 47 | #:multicall-async 48 | 49 | ;; from errors 50 | #:jsonrpc-error 51 | #:jsonrpc-parse-error 52 | #:jsonrpc-invalid-request 53 | #:jsonrpc-invalid-response 54 | #:jsonrpc-method-not-found 55 | #:jsonrpc-invalid-params 56 | #:jsonrpc-internal-error 57 | #:jsonrpc-server-error 58 | #:jsonrpc-error-code 59 | #:jsonrpc-error-message 60 | #:*debug-on-error* 61 | 62 | ;; from this package 63 | #:make-server 64 | #:make-client)) 65 | (in-package #:jsonrpc) 66 | 67 | (defun make-client () 68 | (make-instance 'client)) 69 | 70 | (defun make-server () 71 | (make-instance 'server)) 72 | -------------------------------------------------------------------------------- /tests/transport/stdio.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/tests/transport/stdio 3 | (:use #:cl 4 | #:rove 5 | #:jsonrpc) 6 | (:shadowing-import-from #:rove 7 | #:*debug-on-error*) 8 | (:import-from #:jsonrpc/transport/stdio) 9 | (:import-from #:bordeaux-threads)) 10 | (in-package #:jsonrpc/tests/transport/stdio) 11 | 12 | #+(and sbcl unix) 13 | (deftest stdio-server 14 | (multiple-value-bind (inputfd-1 outputfd-1) 15 | (sb-posix:pipe) 16 | (multiple-value-bind (inputfd-2 outputfd-2) 17 | (sb-posix:pipe) 18 | (let ((server-thread 19 | (bt:make-thread 20 | (lambda () 21 | (let ((server (jsonrpc:make-server))) 22 | (jsonrpc:expose server "sum" (lambda (args) (reduce #'+ args))) 23 | (jsonrpc:server-listen server 24 | :mode :stdio 25 | :input (sb-sys:make-fd-stream inputfd-1 :input t) 26 | :output (sb-sys:make-fd-stream outputfd-2 :output t)))))) 27 | (client (jsonrpc:make-client))) 28 | (unwind-protect 29 | (progn 30 | (sleep 0.5) 31 | (jsonrpc:client-connect client 32 | :mode :stdio 33 | :input (sb-sys:make-fd-stream inputfd-2 :input t) 34 | :output (sb-sys:make-fd-stream outputfd-1 :output t)) 35 | (ok (= (jsonrpc:call client "sum" '(10 20)) 30))) 36 | (bt:destroy-thread server-thread) 37 | (jsonrpc:client-disconnect client)))))) 38 | -------------------------------------------------------------------------------- /errors.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/errors 3 | (:use #:cl) 4 | (:import-from #:yason) 5 | (:export #:jsonrpc-error 6 | #:jsonrpc-parse-error 7 | #:jsonrpc-invalid-request 8 | #:jsonrpc-invalid-response 9 | #:jsonrpc-method-not-found 10 | #:jsonrpc-invalid-params 11 | #:jsonrpc-internal-error 12 | #:jsonrpc-server-error 13 | #:jsonrpc-callback-error 14 | #:jsonrpc-error-code 15 | #:jsonrpc-error-message 16 | #:*debug-on-error*)) 17 | (in-package #:jsonrpc/errors) 18 | 19 | (defvar *debug-on-error* nil 20 | "Open an interactive debugger on any error.") 21 | 22 | (define-condition jsonrpc-error (error) 23 | ((code :initarg :code 24 | :initform -1 25 | :accessor jsonrpc-error-code) 26 | (message :initarg :message 27 | :initform "" 28 | :accessor jsonrpc-error-message))) 29 | 30 | (define-condition jsonrpc-parse-error (jsonrpc-error) 31 | ((code :initform -32700) 32 | (message :initform "Parse error"))) 33 | 34 | (define-condition jsonrpc-invalid-request (jsonrpc-error) 35 | ((code :initform -32600) 36 | (message :initform "Invalid Request"))) 37 | 38 | (define-condition jsonrpc-invalid-response (jsonrpc-error) 39 | ((code :initform -32000) 40 | (message :initform "Invalid Response"))) 41 | 42 | (define-condition jsonrpc-method-not-found (jsonrpc-error) 43 | ((code :initform -32601) 44 | (message :initform "Method not found"))) 45 | 46 | (define-condition jsonrpc-invalid-params (jsonrpc-error) 47 | ((code :initform -32602) 48 | (message :initform "Invalid params"))) 49 | 50 | (define-condition jsonrpc-internal-error (jsonrpc-error) 51 | ((code :initform -32603) 52 | (message :initform "Internal error"))) 53 | 54 | (define-condition jsonrpc-server-error (jsonrpc-error) ()) 55 | 56 | (define-condition jsonrpc-callback-error (jsonrpc-error) () 57 | (:report (lambda (condition stream) 58 | (with-slots (message code) condition 59 | (format stream "JSONRPC-CALLBACK-ERROR: ~A (Code=~A)" message code))))) 60 | 61 | (defmethod yason:encode ((object jsonrpc-error) &optional stream) 62 | (yason:with-output (stream) 63 | (yason:with-object () 64 | (yason:encode-object-element "code" (jsonrpc-error-code object)) 65 | (yason:encode-object-element "message" (jsonrpc-error-message object))))) 66 | -------------------------------------------------------------------------------- /utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/utils 3 | (:use #:cl) 4 | (:import-from #:usocket 5 | #:socket-listen 6 | #:socket-close 7 | #:address-in-use-error) 8 | (:import-from #:bordeaux-threads 9 | #:make-lock 10 | #:with-lock-held 11 | #:destroy-thread) 12 | (:export #:random-port 13 | #:make-id 14 | #:find-mode-class 15 | #:destroy-thread*)) 16 | (in-package #:jsonrpc/utils) 17 | 18 | (defun port-available-p (port) 19 | (handler-case (let ((socket (usocket:socket-listen "127.0.0.1" port :reuse-address t))) 20 | (usocket:socket-close socket)) 21 | (usocket:address-in-use-error (e) (declare (ignore e)) nil))) 22 | 23 | (defun random-port () 24 | "Return a port number not in use from 50000 to 60000." 25 | (loop for port from (+ 50000 (random 1000)) upto 60000 26 | if (port-available-p port) 27 | return port)) 28 | 29 | (defun make-id (&optional (length 12)) 30 | (declare (type fixnum length)) 31 | (let ((result (make-string length))) 32 | (declare (type simple-string result)) 33 | (dotimes (i length result) 34 | (setf (aref result i) 35 | (ecase (random 5) 36 | ((0 1) (code-char (+ #.(char-code #\a) (random 26)))) 37 | ((2 3) (code-char (+ #.(char-code #\A) (random 26)))) 38 | ((4) (code-char (+ #.(char-code #\0) (random 10))))))))) 39 | 40 | (defvar *transport-load-lock* (bt:make-recursive-lock)) 41 | (defun find-mode-class (mode) 42 | (let ((system-name (format nil "jsonrpc/transport/~(~A~)" mode)) 43 | (package-name (format nil "~A/~A" 44 | :jsonrpc/transport 45 | mode))) 46 | 47 | (let ((package 48 | (bt:with-lock-held (*transport-load-lock*) 49 | (or (find-package package-name) 50 | (progn 51 | #+quicklisp 52 | (ql:quickload system-name :silent t) 53 | #-quicklisp 54 | (asdf:load-system system-name :verbose nil) 55 | (find-package package-name)))))) 56 | (and package 57 | (find-class (intern (format nil "~A-~A" mode :transport) package)))))) 58 | 59 | (defun destroy-thread* (thread) 60 | (handler-case 61 | (bt:destroy-thread thread) 62 | ((or #+sbcl sb-thread:interrupt-thread-error) ()))) 63 | -------------------------------------------------------------------------------- /transport/interface.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/transport/interface 3 | (:use #:cl) 4 | (:import-from #:jsonrpc/connection 5 | #:wait-for-ready 6 | #:process-request 7 | #:add-message-to-queue 8 | #:connection-request-queue 9 | #:connection-outbox 10 | #:add-message-to-outbox) 11 | (:import-from #:bordeaux-threads) 12 | (:import-from #:event-emitter 13 | #:event-emitter) 14 | (:import-from #:chanl) 15 | (:export #:transport 16 | #:transport-message-callback 17 | #:transport-connection 18 | #:transport-threads 19 | #:start-server 20 | #:start-client 21 | #:send-message-using-transport 22 | #:receive-message-using-transport 23 | #:run-processing-loop 24 | #:run-reading-loop)) 25 | (in-package #:jsonrpc/transport/interface) 26 | 27 | (defclass transport (event-emitter) 28 | ((message-callback :initarg :message-callback 29 | :accessor transport-message-callback) 30 | (connection :accessor transport-connection) 31 | (threads :initform '() 32 | :accessor transport-threads))) 33 | 34 | (defgeneric start-server (transport)) 35 | 36 | (defgeneric start-client (transport)) 37 | 38 | (defgeneric send-message-using-transport (transport to message)) 39 | 40 | (defgeneric receive-message-using-transport (transport from)) 41 | 42 | (defgeneric run-processing-loop (transport connection) 43 | (:method ((transport transport) connection) 44 | (let ((request-queue (connection-request-queue connection)) 45 | (outbox (connection-outbox connection))) 46 | (handler-case 47 | (loop 48 | (when (and (chanl:recv-blocks-p request-queue) 49 | (chanl:recv-blocks-p outbox)) 50 | (wait-for-ready connection)) 51 | (chanl:select 52 | ((chanl:recv request-queue request) 53 | (let ((response (process-request connection request))) 54 | (when response 55 | (add-message-to-outbox connection response)))) 56 | ((chanl:recv outbox message) 57 | (send-message-using-transport transport connection message)))) 58 | ;; Broken pipe or "something bad happened" from chanl 59 | ((or stream-error #+ccl simple-error) ()))))) 60 | 61 | (defgeneric run-reading-loop (transport connection) 62 | (:method ((transport transport) connection) 63 | (handler-case 64 | (loop for message = (receive-message-using-transport transport connection) 65 | while message 66 | do (add-message-to-queue connection message)) 67 | (end-of-file ())))) 68 | -------------------------------------------------------------------------------- /tests/request-response.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/tests/request-response 3 | (:use #:cl 4 | #:rove 5 | #:jsonrpc/request-response 6 | #:jsonrpc/errors) 7 | (:shadowing-import-from #:rove 8 | #:*debug-on-error*)) 9 | (in-package #:jsonrpc/tests/request-response) 10 | 11 | (deftest parse-message-test 12 | (testing "invalid message" 13 | (ok (signals (parse-message "xxx") 'jsonrpc-parse-error) 14 | "Parse error") 15 | (ok (signals (parse-message "{}") '(or jsonrpc-invalid-request jsonrpc-invalid-response)) 16 | "Empty object is invalid")) 17 | 18 | (testing "invalid request" 19 | (ok (null (parse-message "[]")) 20 | "Empty array is okay (batch request)") 21 | (ok (signals (parse-message "{\"method\":\"add\",\"params\":[1,2],\"id\":1}") 22 | 'jsonrpc-invalid-request) 23 | "\"jsonrpc\" member is missing") 24 | (ok (typep (parse-message "{\"method\":\"add\",\"jsonrpc\":\"2.0\"}") 'request) 25 | "\"params\" and \"id\" can be omitted") 26 | (ok (signals (parse-message "{\"method\":1,\"jsonrpc\":\"2.0\"}") 27 | 'jsonrpc-invalid-request) 28 | "\"method\" must be a string")) 29 | 30 | (testing "invalid response" 31 | (ok (signals (parse-message "{\"id\":1,\"result\":3}") 32 | 'jsonrpc-invalid-response) 33 | "\"jsonrpc\" member is missing") 34 | (ok (typep (parse-message "{\"jsonrpc\":\"2.0\",\"id\":1,\"result\":3}") 35 | 'response)) 36 | (ok (signals (parse-message "{\"jsonrpc\":\"2.0\",\"id\":1,\"result\":3,\"error\":{\"code\":-32000,\"message\":\"something wrong\"}}") 37 | 'jsonrpc-invalid-response) 38 | "Must not to specify both of \"result\" and \"error\"") 39 | (ok (signals (parse-message "{\"jsonrpc\":\"2.0\",\"id\":1,\"error\":\"something wrong\"}") 40 | 'jsonrpc-invalid-response) 41 | "\"error\" must be a string")) 42 | 43 | (testing "general cases" 44 | (let ((message (parse-message "{\"method\":\"add\",\"params\":[1,2],\"id\":1,\"jsonrpc\":\"2.0\"}"))) 45 | (ok (typep message 'request))) 46 | (let ((message (parse-message "{\"jsonrpc\":\"2.0\",\"id\":1,\"error\":{\"code\":-32000,\"message\":\"something wrong\"}}"))) 47 | (ok (typep message 'response))))) 48 | 49 | (deftest json-encode 50 | (testing "request" 51 | (let ((request (make-request :id 1 :method "add" :params '(3 10)))) 52 | (ok (outputs (yason:encode request) 53 | "{\"jsonrpc\":\"2.0\",\"method\":\"add\",\"params\":[3,10],\"id\":1}")))) 54 | (testing "response" 55 | (let ((response (make-response :id 1 :result 13))) 56 | (ok (outputs (yason:encode response) 57 | "{\"jsonrpc\":\"2.0\",\"result\":13,\"id\":1}"))) 58 | (let ((response (make-response :id 2 :result nil))) 59 | (ok (outputs (yason:encode response) 60 | "{\"jsonrpc\":\"2.0\",\"result\":null,\"id\":2}"))))) 61 | -------------------------------------------------------------------------------- /mapper.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/mapper 3 | (:use #:cl 4 | #:jsonrpc/errors) 5 | (:import-from #:jsonrpc/request-response 6 | #:request 7 | #:request-method 8 | #:request-params 9 | #:make-response 10 | #:make-error-response 11 | #:request-id) 12 | (:import-from #:jsonrpc/errors 13 | #:jsonrpc-error 14 | #:jsonrpc-method-not-found 15 | #:jsonrpc-invalid-params) 16 | (:export #:exposable 17 | #:expose 18 | #:register-method 19 | #:clear-methods 20 | #:dispatch)) 21 | (in-package #:jsonrpc/mapper) 22 | 23 | (defclass exposable () 24 | ((mapper :initform (make-hash-table :test 'equal) 25 | :accessor exposable-mapper))) 26 | 27 | (defgeneric expose (object method-name function) 28 | (:method ((object exposable) method-name function) 29 | (setf (gethash method-name (exposable-mapper object)) function))) 30 | (setf (fdefinition 'register-method) #'expose) 31 | 32 | (defgeneric clear-methods (object) 33 | (:method ((object exposable)) 34 | (setf (exposable-mapper object) (make-hash-table :test 'equal)) 35 | (values))) 36 | 37 | (defgeneric dispatch (object message) 38 | (:method ((object exposable) (request request)) 39 | (let ((handler (gethash (request-method request) 40 | (exposable-mapper object)))) 41 | (unless handler 42 | (error 'jsonrpc-method-not-found)) 43 | (let ((result (handler-bind (#+ccl 44 | (ccl::wrong-number-of-arguments 45 | (lambda (e) 46 | (declare (ignore e)) 47 | (error 'jsonrpc-invalid-params))) 48 | #+sbcl 49 | (sb-int:simple-program-error 50 | (lambda (e) 51 | (let ((message (simple-condition-format-control e))) 52 | (when (equal message "invalid number of arguments: ~S") 53 | (error 'jsonrpc-invalid-params)))))) 54 | (funcall handler (request-params request))))) 55 | (when (request-id request) 56 | (make-response :id (request-id request) 57 | :result result))))) 58 | (:method :around ((object exposable) (request request)) 59 | (handler-case 60 | (handler-bind ((error 61 | (lambda (e) 62 | (unless (typep e 'jsonrpc-error) 63 | (cond 64 | (*debug-on-error* 65 | (invoke-debugger e)) 66 | (t 67 | (dissect:present e))))))) 68 | (call-next-method)) 69 | (jsonrpc-error (e) 70 | (when (request-id request) 71 | (make-error-response 72 | :id (request-id request) 73 | :code (jsonrpc-error-code e) 74 | :message (jsonrpc-error-message e)))) 75 | (error () 76 | (when (request-id request) 77 | (let ((e (make-condition 'jsonrpc-internal-error))) 78 | (make-error-response 79 | :id (request-id request) 80 | :code (jsonrpc-error-code e) 81 | :message (jsonrpc-error-message e)))))))) 82 | -------------------------------------------------------------------------------- /transport/stdio.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/transport/stdio 3 | (:use #:cl 4 | #:jsonrpc/transport/interface) 5 | (:import-from #:jsonrpc/connection 6 | #:connection 7 | #:connection-socket) 8 | (:import-from #:yason) 9 | (:import-from #:bordeaux-threads 10 | #:make-thread) 11 | (:import-from #:jsonrpc/utils 12 | #:destroy-thread*) 13 | (:import-from #:jsonrpc/request-response 14 | #:parse-message) 15 | (:export #:stdio-transport)) 16 | (in-package #:jsonrpc/transport/stdio) 17 | 18 | (defclass stdio-transport (transport) 19 | ((input :type stream 20 | :initarg :input 21 | :initform *standard-input* 22 | :accessor stdio-transport-input) 23 | (output :type stream 24 | :initarg :output 25 | :initform *standard-output* 26 | :accessor stdio-transport-output))) 27 | 28 | (defmethod start-server ((transport stdio-transport)) 29 | (let* ((stream (make-two-way-stream (stdio-transport-input transport) 30 | (stdio-transport-output transport))) 31 | (connection (make-instance 'connection 32 | :socket stream 33 | :request-callback (transport-message-callback transport)))) 34 | (setf (transport-connection transport) connection) 35 | (let ((thread 36 | (bt:make-thread 37 | (lambda () 38 | (run-processing-loop transport connection)) 39 | :name "jsonrpc/transport/stdio processing"))) 40 | (unwind-protect (run-reading-loop transport connection) 41 | (destroy-thread* thread))))) 42 | 43 | (defmethod start-client ((transport stdio-transport)) 44 | (let* ((stream (make-two-way-stream (stdio-transport-input transport) 45 | (stdio-transport-output transport))) 46 | (connection (make-instance 'connection 47 | :socket stream 48 | :request-callback (transport-message-callback transport)))) 49 | (setf (transport-connection transport) connection) 50 | 51 | (setf (transport-threads transport) 52 | (list 53 | (bt:make-thread 54 | (lambda () 55 | (run-processing-loop transport connection)) 56 | :name "jsonrpc/transport/stdio processing") 57 | (bt:make-thread 58 | (lambda () 59 | (run-reading-loop transport connection)) 60 | :name "jsonrpc/transport/stdio reading"))) 61 | connection)) 62 | 63 | (defmethod send-message-using-transport ((transport stdio-transport) connection message) 64 | (let ((json (with-output-to-string (s) 65 | (yason:encode message s))) 66 | (stream (connection-socket connection))) 67 | (format stream "Content-Length: ~A~C~C~:*~:*~C~C~A" 68 | (length json) 69 | #\Return 70 | #\Newline 71 | json) 72 | (force-output stream))) 73 | 74 | (defmethod receive-message-using-transport ((transport stdio-transport) connection) 75 | (let* ((stream (connection-socket connection)) 76 | (headers (read-headers stream)) 77 | (length (ignore-errors (parse-integer (gethash "content-length" headers))))) 78 | (when length 79 | (let ((body (make-string length))) 80 | (read-sequence body (stdio-transport-input transport)) 81 | (parse-message body))))) 82 | 83 | ;; character stream 84 | (defun read-headers (stream) 85 | (let ((headers (make-hash-table :test 'equal))) 86 | (loop for line = (read-line stream) 87 | until (equal (string-trim '(#\Return #\Newline) line) "") 88 | do (let* ((colon-pos (position #\: line)) 89 | (field (string-downcase (subseq line 0 colon-pos))) 90 | (value (string-trim '(#\Return #\Space #\Tab) (subseq line (1+ colon-pos))))) 91 | (setf (gethash field headers) value))) 92 | headers)) 93 | -------------------------------------------------------------------------------- /request-response.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/request-response 3 | (:use #:cl 4 | #:jsonrpc/errors) 5 | (:import-from #:yason 6 | #:with-output 7 | #:parse 8 | #:encode 9 | #:with-object 10 | #:encode-object-element) 11 | (:import-from #:alexandria 12 | #:hash-table-keys 13 | #:xor) 14 | (:export #:request 15 | #:response 16 | #:make-request 17 | #:make-response 18 | #:make-error-response 19 | #:request-method 20 | #:request-params 21 | #:request-id 22 | #:response-error 23 | #:response-error-message 24 | #:response-error-code 25 | #:response-result 26 | #:response-id 27 | #:parse-message)) 28 | (in-package #:jsonrpc/request-response) 29 | 30 | (defstruct request 31 | method 32 | params 33 | id) 34 | 35 | (defstruct response 36 | error 37 | result 38 | id) 39 | 40 | (defun make-error-response (&key id code message (data nil data-specified-p)) 41 | (let ((hash (make-hash-table :test 'equal))) 42 | (setf (gethash "code" hash) code 43 | (gethash "message" hash) message) 44 | (when data-specified-p 45 | (setf (gethash "data" hash) data)) 46 | (make-response :error hash :id id))) 47 | 48 | (defun response-error-message (response) 49 | (let ((error (response-error response))) 50 | (when error 51 | (gethash "message" error)))) 52 | 53 | (defun response-error-code (response) 54 | (let ((error (response-error response))) 55 | (when error 56 | (gethash "code" error)))) 57 | 58 | (defun valid-request-p (request) 59 | (and (equal (gethash "jsonrpc" request) "2.0") 60 | (stringp (gethash "method" request)) 61 | (typep (gethash "params" request) 62 | '(or hash-table list)) 63 | (typep (gethash "id" request) 64 | '(or string number null)) 65 | (every (lambda (key) 66 | (find key '("jsonrpc" "method" "params" "id") :test #'string=)) 67 | (hash-table-keys request)))) 68 | 69 | (defun valid-response-p (response) 70 | (and (equal (gethash "jsonrpc" response) "2.0") 71 | (typep (gethash "error" response) 72 | '(or null hash-table)) 73 | (typep (gethash "id" response) 74 | '(or string number null)) 75 | (xor (nth-value 1 (gethash "error" response)) 76 | (nth-value 1 (gethash "result" response))) 77 | (every (lambda (key) 78 | (find key '("jsonrpc" "result" "error" "id") :test #'string=)) 79 | (hash-table-keys response)))) 80 | 81 | (defun parse-message (input) 82 | (when (< 0 (length input)) 83 | (let ((message (handler-case (yason:parse input) 84 | (error () (error 'jsonrpc-parse-error))))) 85 | (flet ((make-message (hash) 86 | (if (gethash "method" hash) 87 | (progn 88 | (unless (valid-request-p hash) 89 | (error 'jsonrpc-invalid-request)) 90 | (make-request :method (gethash "method" hash) 91 | :params (gethash "params" hash) 92 | :id (gethash "id" hash))) 93 | (progn 94 | (unless (valid-response-p hash) 95 | (error 'jsonrpc-invalid-response)) 96 | (make-response :result (gethash "result" hash) 97 | :error (gethash "error" hash) 98 | :id (gethash "id" hash)))))) 99 | (etypecase message 100 | (list 101 | (mapcar #'make-message message)) 102 | (hash-table 103 | (make-message message))))))) 104 | 105 | (defmethod yason:encode ((request request) &optional (stream *standard-output*)) 106 | (yason:with-output (stream) 107 | (yason:with-object () 108 | (yason:encode-object-element "jsonrpc" "2.0") 109 | (yason:encode-object-element "method" (request-method request)) 110 | (yason:encode-object-element "params" (request-params request)) 111 | (when (request-id request) 112 | (yason:encode-object-element "id" (request-id request)))))) 113 | 114 | (defmethod yason:encode ((response response) &optional (stream *standard-output*)) 115 | (yason:with-output (stream) 116 | (yason:with-object () 117 | (yason:encode-object-element "jsonrpc" "2.0") 118 | (if (response-error response) 119 | (yason:encode-object-element "error" (response-error response)) 120 | (yason:encode-object-element "result" (response-result response))) 121 | (yason:encode-object-element "id" (response-id response))))) 122 | -------------------------------------------------------------------------------- /connection.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/connection 3 | (:use #:cl) 4 | (:import-from #:jsonrpc/request-response 5 | #:request 6 | #:response 7 | #:response-id) 8 | (:import-from #:bordeaux-threads 9 | #:make-condition-variable 10 | #:make-recursive-lock 11 | #:with-recursive-lock-held 12 | #:condition-wait 13 | #:condition-notify 14 | #:*default-special-bindings*) 15 | (:import-from #:dissect 16 | #:present) 17 | (:import-from #:event-emitter 18 | #:event-emitter) 19 | (:import-from #:chanl) 20 | (:import-from #:vom) 21 | (:export #:connection 22 | #:*connection* 23 | #:wait-for-ready 24 | #:connection-socket 25 | #:connection-request-callback 26 | #:add-message-to-queue 27 | #:add-message-to-outbox 28 | #:process-request 29 | #:connection-request-queue 30 | #:connection-outbox) 31 | (:documentation "jsonrpc/connection provides a class `connection' for holding data of each connections, like inbox and outbox.")) 32 | (in-package #:jsonrpc/connection) 33 | 34 | (defvar *connection*) 35 | 36 | (defclass process-wait () 37 | ((condvar :initform (bt:make-condition-variable)) 38 | (condlock :initform (bt:make-recursive-lock)))) 39 | 40 | (defgeneric wait-for-ready (process-wait) 41 | (:method ((process-wait process-wait)) 42 | (bt:with-recursive-lock-held ((slot-value process-wait 'condlock)) 43 | (bt:condition-wait (slot-value process-wait 'condvar) 44 | (slot-value process-wait 'condlock))))) 45 | 46 | (defgeneric notify-ready (process-wait) 47 | (:method ((process-wait process-wait)) 48 | (bt:with-recursive-lock-held ((slot-value process-wait 'condlock)) 49 | (bt:condition-notify (slot-value process-wait 'condvar))))) 50 | 51 | (defclass connection (event-emitter process-wait) 52 | ((socket :initarg :socket 53 | :accessor connection-socket) 54 | (request-callback :initarg :request-callback 55 | :accessor connection-request-callback) 56 | 57 | (request-queue :initform (make-instance 'chanl:unbounded-channel) 58 | :accessor connection-request-queue) 59 | 60 | (response-map :initform (make-hash-table :test 'equal)) 61 | (response-lock :initform (bt:make-recursive-lock "jsonrpc/connection response-lock")) 62 | (response-callback :initform (make-hash-table :test 'equal)) 63 | 64 | (outbox :initform (make-instance 'chanl:unbounded-channel) 65 | :accessor connection-outbox))) 66 | 67 | (defgeneric add-message-to-queue (connection message) 68 | ;; batch 69 | (:method ((connection connection) (messages list)) 70 | (if (typep (first messages) 'request) 71 | (progn 72 | (chanl:send (slot-value connection 'request-queue) messages) 73 | (notify-ready connection)) 74 | (dolist (response messages) 75 | (add-message-to-queue connection response))) 76 | (values)) 77 | 78 | (:method ((connection connection) (message request)) 79 | (chanl:send (slot-value connection 'request-queue) message) 80 | (notify-ready connection) 81 | (values)) 82 | 83 | (:method ((connection connection) (message response)) 84 | (let ((id (response-id message))) 85 | (unless id 86 | (warn "Unexpected response which has no id. Ignored.") 87 | (return-from add-message-to-queue)) 88 | 89 | (with-slots (response-map 90 | response-lock 91 | response-callback) connection 92 | (bt:with-recursive-lock-held (response-lock) 93 | (let ((callback (gethash id response-callback))) 94 | (if callback 95 | (progn 96 | (handler-case 97 | (funcall callback message) 98 | (error (e) 99 | (vom:error "~A in a JSON-RPC response callback: ~A" 100 | (type-of e) 101 | e))) 102 | (remhash id response-callback)) 103 | (setf (gethash id response-map) message)))))) 104 | 105 | (values))) 106 | 107 | (defun add-message-to-outbox (connection message) 108 | (chanl:send (connection-outbox connection) message) 109 | (notify-ready connection)) 110 | 111 | (defun set-callback-for-id (connection id callback) 112 | (with-slots (response-map 113 | response-callback 114 | response-lock) connection 115 | (bt:with-recursive-lock-held (response-lock) 116 | (multiple-value-bind (response existsp) 117 | (gethash id response-map) 118 | (if existsp 119 | (progn 120 | (funcall callback response) 121 | (remhash id response-map)) 122 | (setf (gethash id response-callback) callback)))) 123 | (values))) 124 | 125 | (defgeneric process-request (connection request) 126 | ;; batch request 127 | (:method ((connection connection) (requests list)) 128 | (mapcar (lambda (request) 129 | (process-request connection request)) 130 | requests)) 131 | 132 | (:method ((connection connection) (request request)) 133 | (let ((*connection* connection) 134 | (bt:*default-special-bindings* (append `((*connection* . ,connection)) 135 | bt:*default-special-bindings*))) 136 | (funcall (connection-request-callback connection) request)))) 137 | -------------------------------------------------------------------------------- /transport/websocket.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/transport/websocket 3 | (:use #:cl 4 | #:jsonrpc/transport/interface 5 | #:jsonrpc/utils) 6 | (:import-from #:jsonrpc/connection 7 | #:connection 8 | #:connection-socket 9 | #:add-message-to-queue) 10 | (:import-from #:jsonrpc/request-response 11 | #:parse-message) 12 | (:import-from #:jsonrpc/errors 13 | #:jsonrpc-error) 14 | (:import-from #:bordeaux-threads 15 | #:make-thread) 16 | (:import-from #:event-emitter 17 | #:on 18 | #:emit) 19 | (:import-from #:yason) 20 | (:import-from #:quri) 21 | (:import-from #:websocket-driver) 22 | (:import-from #:clack) 23 | (:import-from #:clack.handler.hunchentoot) 24 | (:export #:websocket-transport)) 25 | (in-package #:jsonrpc/transport/websocket) 26 | 27 | (defclass websocket-transport (transport) 28 | ((host :accessor websocket-transport-host 29 | :initarg :host 30 | :initform "127.0.0.1") 31 | (port :accessor websocket-transport-port 32 | :initarg :port 33 | :initform (random-port)) 34 | (securep :accessor websocket-transport-secure-p 35 | :initarg :securep 36 | :initform nil) 37 | (debug :initarg :debug 38 | :initform t))) 39 | 40 | (defmethod initialize-instance :after ((transport websocket-transport) &rest initargs &key url &allow-other-keys) 41 | (declare (ignore initargs)) 42 | (when url 43 | (let ((uri (quri:uri url))) 44 | (unless (member (quri:uri-scheme uri) '("ws" "wss") :test #'equalp) 45 | (error "Only ws or wss are supported for websocket-transport (specified ~S)" (quri:uri-scheme uri))) 46 | (setf (websocket-transport-secure-p transport) 47 | (equalp (quri:uri-scheme uri) "wss")) 48 | (setf (websocket-transport-host transport) (quri:uri-host uri)) 49 | (setf (websocket-transport-port transport) (quri:uri-port uri)))) 50 | transport) 51 | 52 | (defmethod start-server ((transport websocket-transport)) 53 | (setf (transport-connection transport) 54 | (clack:clackup 55 | (lambda (env) 56 | (block nil 57 | ;; Return 200 OK for non-WebSocket requests 58 | (unless (wsd:websocket-p env) 59 | (return '(200 () ("ok")))) 60 | (let* ((ws (wsd:make-server env)) 61 | (connection (make-instance 'connection 62 | :socket ws 63 | :request-callback 64 | (transport-message-callback transport)))) 65 | 66 | (on :message ws 67 | (lambda (input) 68 | (let ((message (handler-case (parse-message input) 69 | (jsonrpc-error () 70 | ;; Nothing can be done 71 | nil)))) 72 | (when message 73 | (add-message-to-queue connection message))))) 74 | 75 | (on :open ws 76 | (lambda () 77 | (emit :open transport connection))) 78 | 79 | (on :close ws 80 | (lambda (&key code reason) 81 | (declare (ignore code reason)) 82 | (emit :close connection))) 83 | 84 | (lambda (responder) 85 | (declare (ignore responder)) 86 | (let ((thread 87 | (bt:make-thread 88 | (lambda () 89 | (run-processing-loop transport connection)) 90 | :name "jsonrpc/transport/websocket processing"))) 91 | (unwind-protect 92 | (wsd:start-connection ws) 93 | (bt:destroy-thread thread))))))) 94 | :host (websocket-transport-host transport) 95 | :port (websocket-transport-port transport) 96 | :server :hunchentoot 97 | :debug (slot-value transport 'debug) 98 | :use-thread nil))) 99 | 100 | (defmethod start-client ((transport websocket-transport)) 101 | (let* ((client (wsd:make-client (format nil "~A://~A:~A/" 102 | (if (websocket-transport-secure-p transport) 103 | "wss" 104 | "ws") 105 | (websocket-transport-host transport) 106 | (websocket-transport-port transport)))) 107 | (connection (make-instance 'connection 108 | :socket client 109 | :request-callback 110 | (transport-message-callback transport)))) 111 | (on :open client 112 | (lambda () 113 | (emit :open transport connection))) 114 | 115 | (on :close client 116 | (lambda (&key code reason) 117 | (declare (ignore code reason)) 118 | ;; Reconnect automatically 119 | (wsd:start-connection client))) 120 | 121 | (on :message client 122 | (lambda (input) 123 | (let ((message (parse-message input))) 124 | (when message 125 | (add-message-to-queue connection message))))) 126 | 127 | (wsd:start-connection client) 128 | (setf (transport-connection transport) connection) 129 | 130 | (setf (transport-threads transport) 131 | (list 132 | (bt:make-thread 133 | (lambda () 134 | (run-processing-loop transport connection)) 135 | :name "jsonrpc/transport/websocket processing") 136 | ;; KLUDGE: Requires to kill the read-thread of WebSocket client 137 | ;; for calling 'close-connection'. 138 | ;; Perhaps, finalization should be done in other places. 139 | (slot-value client 'websocket-driver.ws.client::read-thread))) 140 | connection)) 141 | 142 | (defmethod send-message-using-transport ((transport websocket-transport) connection message) 143 | (let ((json (with-output-to-string (s) 144 | (yason:encode message s))) 145 | (ws (connection-socket connection))) 146 | (wsd:send ws json))) 147 | 148 | (defmethod receive-message-using-transport ((transport websocket-transport) connection) 149 | (error "Not allowed to receive synchronously with WebSocket transport.")) 150 | -------------------------------------------------------------------------------- /transport/tcp.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/transport/tcp 3 | (:use #:cl 4 | #:jsonrpc/utils 5 | #:jsonrpc/transport/interface) 6 | (:import-from #:jsonrpc/connection 7 | #:connection 8 | #:connection-socket) 9 | (:import-from #:jsonrpc/request-response 10 | #:parse-message) 11 | (:import-from #:usocket) 12 | (:import-from #:cl+ssl) 13 | (:import-from #:quri) 14 | (:import-from #:yason) 15 | (:import-from #:bordeaux-threads 16 | #:make-thread) 17 | (:import-from #:fast-io 18 | #:make-output-buffer 19 | #:finish-output-buffer 20 | #:fast-write-byte) 21 | (:import-from #:event-emitter 22 | #:emit) 23 | (:import-from #:trivial-utf-8 24 | #:utf-8-bytes-to-string 25 | #:string-to-utf-8-bytes) 26 | (:export #:tcp-transport)) 27 | (in-package #:jsonrpc/transport/tcp) 28 | 29 | (define-condition eof (error) ()) 30 | 31 | (defclass tcp-transport (transport) 32 | ((host :accessor tcp-transport-host 33 | :initarg :host 34 | :initform "127.0.0.1") 35 | (port :accessor tcp-transport-port 36 | :initarg :port 37 | :initform (random-port)) 38 | (securep :accessor tcp-transport-secure-p 39 | :initarg :securep 40 | :initform nil))) 41 | 42 | (defmethod initialize-instance :after ((transport tcp-transport) &rest initargs &key url &allow-other-keys) 43 | (declare (ignore initargs)) 44 | (when url 45 | (let ((uri (quri:uri url))) 46 | (unless (quri:uri-http-p uri) 47 | (error "Only http or https are supported for tcp-transport (specified ~S)" (quri:uri-scheme uri))) 48 | (setf (tcp-transport-secure-p transport) 49 | (equalp (quri:uri-scheme uri) "https")) 50 | (setf (tcp-transport-host transport) (quri:uri-host uri)) 51 | (setf (tcp-transport-port transport) (quri:uri-port uri)))) 52 | transport) 53 | 54 | (defmethod start-server ((transport tcp-transport)) 55 | (usocket:with-socket-listener (server (tcp-transport-host transport) 56 | (tcp-transport-port transport) 57 | :reuse-address t 58 | :element-type '(unsigned-byte 8)) 59 | (setf (transport-connection transport) server) 60 | (let ((callback (transport-message-callback transport)) 61 | (client-threads '()) 62 | (bt:*default-special-bindings* (append bt:*default-special-bindings* 63 | `((*standard-output* . ,*standard-output*) 64 | (*error-output* . ,*error-output*))))) 65 | (unwind-protect 66 | (loop 67 | (usocket:wait-for-input (list server) :timeout 10) 68 | (when (member (usocket:socket-state server) '(:read :read-write)) 69 | (let* ((socket (usocket:socket-accept server)) 70 | (connection (make-instance 'connection 71 | :socket (usocket:socket-stream socket) 72 | :request-callback callback))) 73 | (emit :open transport connection) 74 | (push 75 | (bt:make-thread 76 | (lambda () 77 | (let ((thread 78 | (bt:make-thread 79 | (lambda () 80 | (run-processing-loop transport connection)) 81 | :name "jsonrpc/transport/tcp processing" 82 | :initial-bindings 83 | `((*standard-output* . ,*standard-output*) 84 | (*error-output* . ,*error-output*))))) 85 | (unwind-protect 86 | (run-reading-loop transport connection) 87 | (finish-output (connection-socket connection)) 88 | (usocket:socket-close socket) 89 | (destroy-thread* thread) 90 | (emit :close connection)))) 91 | :name "jsonrpc/transport/tcp reading") 92 | client-threads)))) 93 | (mapc #'destroy-thread* client-threads))))) 94 | 95 | (defmethod start-client ((transport tcp-transport)) 96 | (let ((stream (usocket:socket-stream 97 | (usocket:socket-connect (tcp-transport-host transport) 98 | (tcp-transport-port transport) 99 | :element-type '(unsigned-byte 8))))) 100 | (setf stream 101 | (if (tcp-transport-secure-p transport) 102 | (cl+ssl:make-ssl-client-stream stream 103 | :hostname (tcp-transport-host transport)) 104 | stream)) 105 | 106 | (let ((connection (make-instance 'connection 107 | :socket stream 108 | :request-callback 109 | (transport-message-callback transport))) 110 | (bt:*default-special-bindings* (append bt:*default-special-bindings* 111 | `((*standard-output* . ,*standard-output*) 112 | (*error-output* . ,*error-output*))))) 113 | (setf (transport-connection transport) connection) 114 | 115 | (emit :open transport connection) 116 | 117 | (setf (transport-threads transport) 118 | (list 119 | (bt:make-thread 120 | (lambda () 121 | (run-processing-loop transport connection)) 122 | :name "jsonrpc/transport/tcp processing") 123 | 124 | (bt:make-thread 125 | (lambda () 126 | (run-reading-loop transport connection)) 127 | :name "jsonrpc/transport/tcp reading"))) 128 | 129 | connection))) 130 | 131 | (defmethod send-message-using-transport ((transport tcp-transport) connection message) 132 | (let* ((json (with-output-to-string (s) 133 | (yason:encode message s))) 134 | (body (string-to-utf-8-bytes json)) 135 | (stream (connection-socket connection))) 136 | (write-sequence 137 | (string-to-utf-8-bytes 138 | (format nil 139 | "Content-Length: ~A~C~C~:*~:*~C~C" 140 | (length body) 141 | #\Return 142 | #\Newline)) 143 | stream) 144 | (write-sequence body stream) 145 | (force-output stream))) 146 | 147 | (defmethod receive-message-using-transport ((transport tcp-transport) connection) 148 | (handler-case 149 | (let* ((stream (connection-socket connection)) 150 | (headers (read-headers stream)) 151 | (length (ignore-errors (parse-integer (gethash "content-length" headers))))) 152 | (when length 153 | (let ((body (make-array length :element-type '(unsigned-byte 8)))) 154 | (read-sequence body stream) 155 | ;; TODO: error handling 156 | (parse-message (utf-8-bytes-to-string body))))) 157 | (eof () nil))) 158 | 159 | (defun read-headers (stream) 160 | (let (header-field 161 | (headers (make-hash-table :test 'equal))) 162 | 163 | (tagbody 164 | read-header-field 165 | (let ((buffer (fast-io:make-output-buffer))) 166 | ;; The last of headers 167 | (let ((byte (read-byte stream nil 0))) 168 | (cond 169 | ((= byte (char-code #\Return)) 170 | (progn 171 | (assert (= (read-byte stream nil 0) (char-code #\Linefeed))) 172 | (go finish))) 173 | ((= byte 0) 174 | (go eof)) 175 | (t 176 | (fast-write-byte byte buffer)))) 177 | (loop for byte of-type (unsigned-byte 8) = (read-byte stream nil 0) 178 | if (= byte (char-code #\:)) 179 | do (setf header-field 180 | (string-downcase 181 | (map 'string #'code-char (fast-io:finish-output-buffer buffer)))) 182 | (go read-header-value) 183 | else if (= byte 0) 184 | do (go eof) 185 | else if (= byte (char-code #\Return)) 186 | do (go read-lf) 187 | else 188 | do (fast-write-byte byte buffer))) 189 | 190 | read-header-value 191 | (let ((buffer (fast-io:make-output-buffer))) 192 | (let ((byte (read-byte stream nil 0))) 193 | (unless (= byte (char-code #\Space)) 194 | (fast-io:fast-write-byte byte buffer))) 195 | (loop for byte of-type (unsigned-byte 8) = (read-byte stream nil 0) 196 | if (= byte 0) 197 | do (go eof) 198 | else if (= byte (char-code #\Return)) 199 | ;; FIXME: The same header field can be found and should be concatenated into the same value 200 | do (setf (gethash header-field headers) 201 | (map 'string #'code-char (fast-io:finish-output-buffer buffer))) 202 | (go read-lf) 203 | else 204 | do (fast-write-byte byte buffer) 205 | until (= byte (char-code #\Return)))) 206 | 207 | read-lf 208 | (let ((byte (read-byte stream nil 0))) 209 | (assert (= byte (char-code #\Linefeed))) 210 | (go read-header-field)) 211 | 212 | eof 213 | (error 'eof) 214 | 215 | finish) 216 | 217 | headers)) 218 | -------------------------------------------------------------------------------- /class.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:jsonrpc/class 3 | (:use #:cl) 4 | (:import-from #:jsonrpc/mapper 5 | #:exposable 6 | #:expose 7 | #:register-method 8 | #:clear-methods 9 | #:dispatch) 10 | (:import-from #:jsonrpc/transport/interface 11 | #:transport 12 | #:transport-connection 13 | #:transport-threads 14 | #:start-server 15 | #:start-client 16 | #:receive-message-using-transport) 17 | (:import-from #:jsonrpc/connection 18 | #:*connection* 19 | #:set-callback-for-id 20 | #:add-message-to-outbox) 21 | (:import-from #:jsonrpc/request-response 22 | #:make-request 23 | #:response-error 24 | #:response-error-code 25 | #:response-error-message 26 | #:response-result) 27 | (:import-from #:jsonrpc/errors 28 | #:jsonrpc-callback-error) 29 | (:import-from #:jsonrpc/utils 30 | #:find-mode-class 31 | #:make-id 32 | #:destroy-thread*) 33 | (:import-from #:bordeaux-threads 34 | #:*default-special-bindings*) 35 | (:import-from #:event-emitter 36 | #:on 37 | #:emit 38 | #:event-emitter) 39 | (:import-from #:alexandria 40 | #:remove-from-plist) 41 | (:export #:*default-timeout* 42 | #:client 43 | #:server 44 | #:jsonrpc-transport 45 | #:expose 46 | #:register-method 47 | #:clear-methods 48 | #:dispatch 49 | #:server-listen 50 | #:client-connect 51 | #:client-disconnect 52 | #:send-message 53 | #:receive-message 54 | #:call-to 55 | #:call-async-to 56 | #:notify-to 57 | #:call 58 | #:call-async 59 | #:notify 60 | #:notify-async 61 | #:broadcast 62 | #:multicall-async)) 63 | (in-package #:jsonrpc/class) 64 | 65 | (defvar *default-timeout* 60) 66 | 67 | (defclass jsonrpc (event-emitter exposable) 68 | ((transport :type (or null transport) 69 | :initarg :transport 70 | :initform nil 71 | :accessor jsonrpc-transport))) 72 | 73 | (defun ensure-connected (jsonrpc) 74 | (check-type jsonrpc jsonrpc) 75 | (unless (jsonrpc-transport jsonrpc) 76 | (error "Connection isn't established yet for ~A" jsonrpc))) 77 | 78 | (defclass client (jsonrpc) ()) 79 | 80 | (defclass server (jsonrpc) 81 | ((client-connections :initform '() 82 | :accessor server-client-connections) 83 | (%lock :initform (bt:make-lock "client-connections-lock")))) 84 | 85 | (defun server-listen (server &rest initargs &key mode &allow-other-keys) 86 | (let* ((class (find-mode-class mode)) 87 | (initargs (remove-from-plist initargs :mode)) 88 | (bt:*default-special-bindings* `((*standard-output* . ,*standard-output*) 89 | (*error-output* . ,*error-output*)) )) 90 | (unless class 91 | (error "Unknown mode ~A" mode)) 92 | (let ((transport (apply #'make-instance class 93 | :message-callback 94 | (lambda (message) 95 | (dispatch server message)) 96 | initargs))) 97 | (setf (jsonrpc-transport server) transport) 98 | 99 | (on :open transport 100 | (lambda (connection) 101 | (with-slots (%lock client-connections) server 102 | (on :close connection 103 | (lambda () 104 | (bt:with-lock-held (%lock) 105 | (setf client-connections 106 | (delete connection client-connections))))) 107 | (bt:with-lock-held (%lock) 108 | (push connection client-connections))) 109 | (emit :open server connection))) 110 | 111 | (start-server transport))) 112 | server) 113 | 114 | (defun client-connect (client &rest initargs &key mode &allow-other-keys) 115 | (let* ((class (find-mode-class mode)) 116 | (initargs (remove-from-plist initargs :mode)) 117 | (bt:*default-special-bindings* `((*standard-output* . ,*standard-output*) 118 | (*error-output* . ,*error-output*)) )) 119 | (unless class 120 | (error "Unknown mode ~A" mode)) 121 | (let ((transport (apply #'make-instance class 122 | :message-callback 123 | (lambda (message) 124 | (dispatch client message)) 125 | initargs))) 126 | (setf (jsonrpc-transport client) transport) 127 | 128 | (on :open transport 129 | (lambda (connection) 130 | (emit :open client connection))) 131 | 132 | (start-client transport))) 133 | client) 134 | 135 | (defun client-disconnect (client) 136 | (ensure-connected client) 137 | (let ((transport (jsonrpc-transport client))) 138 | (mapc #'destroy-thread* (transport-threads transport)) 139 | (setf (transport-threads transport) '()) 140 | (setf (transport-connection transport) nil)) 141 | (emit :close client) 142 | (values)) 143 | 144 | (defgeneric send-message (to connection message) 145 | (:method (to connection message) 146 | (declare (ignore to)) 147 | (add-message-to-outbox connection message))) 148 | 149 | (defun receive-message (from connection) 150 | (ensure-connected from) 151 | (receive-message-using-transport (jsonrpc-transport from) connection)) 152 | 153 | (deftype jsonrpc-params () '(or list array hash-table structure-object standard-object condition)) 154 | 155 | (defun call-async-to (from to method &optional params callback error-callback) 156 | (check-type params jsonrpc-params) 157 | (let ((id (make-id))) 158 | (set-callback-for-id to 159 | id 160 | (lambda (response) 161 | (if (response-error response) 162 | (and error-callback 163 | (funcall error-callback 164 | (response-error-message response) 165 | (response-error-code response))) 166 | (and callback 167 | (funcall callback (response-result response)))))) 168 | 169 | (send-message from 170 | to 171 | (make-request :id id 172 | :method method 173 | :params params)) 174 | 175 | (values))) 176 | 177 | (defvar *call-to-result* (make-hash-table :test 'eq)) 178 | (defvar *call-to-error* (make-hash-table :test 'eq)) 179 | 180 | (defun hash-exists-p (hash-table key) 181 | (nth-value 1 (gethash key hash-table))) 182 | 183 | (defun call-to (from to method &optional params &rest options) 184 | (destructuring-bind (&key (timeout *default-timeout*)) options 185 | (let ((condvar (bt:make-condition-variable)) 186 | (condlock (bt:make-lock)) 187 | (readylock (bt:make-lock))) 188 | (bt:acquire-lock readylock) 189 | (call-async-to from to 190 | method 191 | params 192 | (lambda (res) 193 | (bt:with-lock-held (readylock) 194 | (bt:with-lock-held (condlock) 195 | (setf (gethash readylock *call-to-result*) res) 196 | (bt:condition-notify condvar)))) 197 | (lambda (message code) 198 | (bt:with-lock-held (readylock) 199 | (bt:with-lock-held (condlock) 200 | (setf (gethash readylock *call-to-error*) 201 | (make-condition 'jsonrpc-callback-error 202 | :message message 203 | :code code)) 204 | (bt:condition-notify condvar))))) 205 | (bt:with-lock-held (condlock) 206 | (bt:release-lock readylock) 207 | (unless (bt:condition-wait condvar condlock :timeout timeout) 208 | (error "JSON-RPC synchronous call has been timeout"))) 209 | 210 | ;; XXX: Strangely enough, there's sometimes no results/errors here on SBCL. 211 | #+(and sbcl linux) 212 | (loop repeat 5 213 | until (or (hash-exists-p *call-to-result* readylock) 214 | (hash-exists-p *call-to-error* readylock)) 215 | do (sleep 0.1)) 216 | 217 | (multiple-value-bind (error error-exists-p) 218 | (gethash readylock *call-to-error*) 219 | (multiple-value-bind (result result-exists-p) 220 | (gethash readylock *call-to-result*) 221 | (assert (or error-exists-p 222 | result-exists-p)) 223 | (remhash readylock *call-to-error*) 224 | (remhash readylock *call-to-result*) 225 | (if error 226 | (error error) 227 | result)))))) 228 | 229 | (defun notify-to (from to method &optional params) 230 | (check-type params jsonrpc-params) 231 | (send-message from 232 | to 233 | (make-request :method method 234 | :params params))) 235 | 236 | (defgeneric call (jsonrpc method &optional params &rest options) 237 | (:method ((client client) method &optional params &rest options) 238 | (ensure-connected client) 239 | (apply #'call-to client (transport-connection (jsonrpc-transport client)) 240 | method params options))) 241 | 242 | (defgeneric call-async (jsonrpc method &optional params callback error-callback) 243 | (:method ((client client) method &optional params callback error-callback) 244 | (ensure-connected client) 245 | (call-async-to client (transport-connection (jsonrpc-transport client)) 246 | method params 247 | callback 248 | error-callback)) 249 | (:method ((server server) method &optional params callback error-callback) 250 | (unless (boundp '*connection*) 251 | (error "`call' is called outside of handlers.")) 252 | (call-async-to server *connection* method params callback error-callback))) 253 | 254 | (defgeneric notify (jsonrpc method &optional params) 255 | (:method ((client client) method &optional params) 256 | (ensure-connected client) 257 | (notify-to client (transport-connection (jsonrpc-transport client)) 258 | method params)) 259 | (:method ((server server) method &optional params) 260 | (unless (boundp '*connection*) 261 | (error "`notify' is called outside of handlers.")) 262 | (notify-to server *connection* 263 | method params))) 264 | 265 | (defgeneric notify-async (jsonrpc method &optional params) 266 | (:method ((client client) method &optional params) 267 | (ensure-connected client) 268 | (let ((connection (transport-connection (jsonrpc-transport client)))) 269 | (send-message client connection 270 | (make-request :method method 271 | :params params)))) 272 | (:method ((server server) method &optional params) 273 | (unless (boundp '*connection*) 274 | (error "`notify-async' is called outside of handlers.")) 275 | (send-message server *connection* 276 | (make-request :method method 277 | :params params)))) 278 | 279 | ;; Experimental 280 | (defgeneric broadcast (jsonrpc method &optional params) 281 | (:method ((server server) method &optional params) 282 | (dolist (conn (server-client-connections server)) 283 | (notify server conn method params)))) 284 | 285 | ;; Experimental 286 | (defgeneric multicall-async (jsonrpc method &optional params callback error-callback) 287 | (:method ((server server) method &optional params callback error-callback) 288 | (dolist (conn (server-client-connections server)) 289 | (call-async-to server conn method params 290 | callback 291 | error-callback)))) 292 | --------------------------------------------------------------------------------