;; An implementation of the JSON-RPC protocol
;; This file contains a client implementation.
; Copyright (c) 2013, Tim van der Linden
; All rights reserved.
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are met:
; Redistributions of source code must retain the above copyright notice, this
; list of conditions and the following disclaimer.
; Redistributions in binary form must reproduce the above copyright notice,
; this list of conditions and the following disclaimer in the documentation
; and/or other materials provided with the distribution.
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission.
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;;; --> Symbol hack -> Make method a symbol for notification, string for no notification
;;; --> Create worker thread with read-json loop for catching input (dispatcher)
;;; --> Dispatch notifications from server and responses to different mailboxes
(import chicken scheme)
(use medea extras srfi-1 data-structures mailbox-threads loop)
; Setup the custom error handlers
(define (server-setup-arguments-error type expected given)
(sprintf "Cannot setup connection, the ~S is invalid. Expected ~A type but got ~A."
type expected given))))
(define (server-setup-data-error type message)
(sprintf "Cannot build JSON-RPC request, the given ~S data is invalid. The ~S ~A"
type type message))))
(define (json-rpc-server-error code message)
(sprintf "The JSON-RPC server returned an error. Errorcode: ~A, Native message: ~A"
; Helper for checking which type we have, did not want to use another dependency for that :)
(define (get-type x)
(cond ((input-port? x) "an input port")
((output-port? x) "an output port")
((number? x) "a mumber")
((pair? x) "a pair")
((string? x) "a string")
((list? x) "a list")
((vector? x) "a vector")
((boolean? x) "a boolean")
; Setup the server and return a procedure to setup the method and optional params
; Do some basic checking if the input, output and version are as expected
;; - input: input port of the JSON-RPC server
;; - ouptput: ouput port of the JSON-RPC server
;; - version: the JSON-RPC version in which we want to communicate
(define (json-rpc-server input output #!optional (version "2.0"))
(cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
(thread-start! (thread-listener input))
(lambda (method . params)
(cond ((not (is-valid-method? method)) (server-setup-data-error "method" "can only be a string or a symbol."))
((not (are-valid-params? params)) (server-setup-data-error "params" "can only be a vector or an alist."))
(send-request (remove null? (list (cons 'jsonrpc version)
(cons 'method (if (symbol? method)
(if (null? params)
(cons 'params (build-params params)))
(if (symbol? method) ;Hack to make this request a notification or not
(cons 'id "1")))) ;ID is hardcoded - can't handle more then one request at a time...or can we?
; Helper for building a vector or alist from the parameters if present
(define (build-params params)
(if (keyword? (car params))
(list->vector (build-vector params))))
; Helper for building an alist
(define (build-alist params)
(if (null? params)
(cons (cons (car params) (car (cdr params))) (build-alist (cdr (cdr params))))))
; Helper for building a vector
(define (build-vector params)
(if (null? params)
(cons (symbol->string(car params)) (build-vector (cdr params)))))
; Check if the method is a string as defined in the spec...or a symbol, which is a small hack to set the request as a notification
(define (is-valid-method? method)
(or (string? method)
; Check if the params are a list as defined in the spec
(define (are-valid-params? params)
(list? params)) ;Assumptions? Don't know if this check is enough (check for null (is also a list) or list)
; Check if the version is correctly formatted as defined in the spec
(define (is-valid-version? version)
(string=? version "2.0"))
; Send the actual request using Medea
(define (send-request request output)
(write-json request output))
; Create the looping listener thread which will dispatch messages to various thread-mailboxes
;; Keep reading the JSON sent back from the server, if the ID is equal to the sender, dispatch a message
;; to the current threads mailbox. Otherwise send the message to the public threads mailbox.
(define (thread-listener input)
(make-thread (lambda () (loop
(let ((data (read-json input #f)))
(cond ((alist-ref 'id data) (thread-send (current-thread) "There is a response"))
(thread-send (current-thread) "This is a service announcment")))))
; Create the "public" thread which mailbox is used for server messages intended for all clients.
; (make-thread (lambda () (pp (thread-receive 999))) 'public))