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.

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

(import chicken scheme)
(use medea extras srfi-1)

; 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 setup connection, the given ~S data is invalid. The ~S ~A"
	      type type 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
	   (lambda (method . params)
	     (cond ((not (is-valid-method? method)) (server-setup-data-error "method" "can only be a string."))
		   ((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 method)
						      (if (null? params) '()
							  (cons 'params (build-params params)))
						      (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
(define (is-valid-method? method)
    (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))

)