Commits

Limburgse Natuurgidsen committed a1ae15b

- Expanded the JSON-RPC basic error handler to be SPEC compliant
- Added small test-mode flag to not wait for thread-mailboxes during test cycles
- Updated the test suite
- Fixed some typos

Comments (0)

Files changed (2)

json-rpc-client.scm

     (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)
+; As specified in the spec, when in error, the JSON-RPC server MUST return a code and a native message
+; and MAY return additional data in structured form.
+(define (json-rpc-server-error code message #!optional data)
   (signal
-   (make-property-condition
-    'exn 'message
-    (sprintf "The JSON-RPC server returned an error. Errorcode: ~A, Native message: ~A"
-	     code message))))
+    (make-property-condition
+     'exn 'message
+     (sprintf "The JSON-RPC server returned an error. ~%Errorcode: ~A ~%Native message: ~A ~%Native data: ~A"
+	      code message (if data
+			       data
+			       "No data returned.")))))
 
 ; 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")
+	((number? x) "a number")
 	((pair? x) "a pair")
 	((string? x) "a string")
 	((list? x) "a list")
 ;; - version: the JSON-RPC version in which we want to communicate
 ;; - full-data: disclose full data or only the SPEC compliant "result" part of the response
 ;; - public-receiver: user defined procedure which will fire when receiving a broadcast message 
+;; - test-mode: simple flag that gives the ability to not wait on thread-mailbox input when running a test cycle
 ;;
 ;; When successfully called, the lambda will return the CHICKEN data containing the server response
 ;; unless we send the request as a notification
-(define (json-rpc-server input output #!key (version "2.0") (full-data #f) (public-receiver #f))
+(define (json-rpc-server input output #!key (version "2.0") (full-data #f) (public-receiver #f) (test-mode #f))
   (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 (output-port? output)) (server-setup-arguments-error "output port" "output-port" (get-type output)))
 	((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
 	(else
 	 (thread-start! (listener-thread input (current-thread) public-receiver)) ; Start the looping listener thread
 							'()
 							(cons 'id "1")))) ; ID is hardcoded - can't handle more then one request at a time...or can we?
 				output)
-		  (if (symbol? method) 
-		      #f ; If it is a symbol, then we do not expect a response, so return #f
-		      (if full-data
-			  (thread-receive) ; Return the full response data
-			  (let ((data (thread-receive)))
-				(cond ((alist-ref 'result data) (alist-ref 'result data)) ; Return only the "result" part of the response
-				      ((alist-ref 'error data) (alist-ref 'error data)))))))))))) ; Return only the "error" part of the response
+		  (when (and (not (symbol? method)) ; If it is not a symbol, then we expect a response 
+			     (not test-mode)) ; If we are not in test-mode, then we expect a response
+			(if full-data
+			    (thread-receive) ; Return the full response data
+			    (let ((data (thread-receive))) ; Else drill down and get the pretty parts
+			      (cond ((alist-ref 'result data) (alist-ref 'result data)) ; Return only the "result" part of the response
+				    ((alist-ref 'error data) ; If we get an error from the server, raise a json-rpc-server error type 
+				     (json-rpc-server-error
+				      (alist-ref 'code (alist-ref 'error data))
+				      (alist-ref 'message (alist-ref 'error data))
+				      (if (alist-ref 'data (alist-ref 'error data))
+					  (alist-ref 'data (alist-ref 'error data))
+					  #f)))))))))))))
 
 ; Helper for building a vector or alist from the parameters if present
 (define (build-params params)
 ; Setup global string ports and server for testing
 (define input (open-input-string "some-string"))
 (define output (open-output-string))
-(define xbmc (json-rpc-server input output "2.0"))
+(define xbmc (json-rpc-server input output))
 
 ; Setup own test procedure with locally scoped output ports
 (define (test-server description expected method . params)
   (let ((output (open-output-string)))
-    (apply (json-rpc-server input output "2.0") method #f params)
+    (apply (json-rpc-server input output test-mode: #t) method params)
     (test
      description
      expected
  
 ; Do some actual error testing
 (test-group "Non-port or non-version calls"
-	    (test-error "Non port call on input" (json-rpc-server "input" output "2.0"))
-	    (test-error "Non port call on output" (json-rpc-server input "output" "2.0"))
-	    (test-error "Non correct version number call" (json-rpc-server input output "3.0")))
+	    (test-error "Non port call on input" (json-rpc-server "input" output))
+	    (test-error "Non port call on output" (json-rpc-server input "output"))
+	    (test-error "Non correct version number call" (json-rpc-server input output version: "3.0")))
 
 (test-group "Non-string method calls"
 	    (test-error "Call method as symbol" (xbmc #f 'foo))