Source

json-rpc / json-rpc-client.scm

Full commit
;;;; json-rpc-client.scm
;
;; 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

(module json-rpc-client
  (json-rpc-server)

(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)
  (signal
   (make-property-condition
    'exn 'message
    (sprintf "Cannot setup connection, the ~S is invalid. Expected ~A type but got ~A."
	     type expected given))))

(define (server-setup-data-error type message)
  (signal
   (make-property-condition
    'exn '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)
  (signal
   (make-property-condition
    'exn 'message
    (sprintf "The JSON-RPC server returned an error. Errorcode: ~A, Native message: ~A"
	     code message))))

; 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")
	("something unknown")))

; 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))
	(else
	 (thread-start! (thread-listener input))
	 ;(thread-start! thread-public)
	 (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."))
		 (else
		  (send-request (remove null? (list (cons 'jsonrpc version)
						    (cons 'method (if (symbol? method)
								      (symbol->string method)
								      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?
				output)))))))

; Helper for building a vector or alist from the parameters if present
(define (build-params params)
  (if (keyword? (car params)) 
      (build-alist 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)
      (symbol? 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")))))
	       'listener))

; Create the "public" thread which mailbox is used for server messages intended for all clients.
;(define thread-public
;  (make-thread (lambda () (pp (thread-receive 999))) 'public))
 
)