[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/extensions.lisp s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/package.lisp
Rudi Schlatte
rschlatte at common-lisp.net
Thu Jun 17 19:43:11 UTC 2004
Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src
In directory common-lisp.net:/tmp/cvs-serv10345/src
Modified Files:
xml-rpc.lisp package.lisp
Added Files:
extensions.lisp
Log Message:
- Add extensions.lisp, for the various add-on specs floating around
that cluttered xml-rpc.lisp
- New file test-extensions.lisp, for testing them
- Add support for symbols client-side (encode them as strings)
- Extension system.getCapabilities: implemented, spec at
http://groups.yahoo.com/group/xml-rpc/message/2897
- Add passing of symbols (encode them as strings)- Use standard error codes (spec at
http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php), wonder
about semantics of "internal xml-rpc error" vs "application error",
pick one arbitrarily
Date: Thu Jun 17 12:43:11 2004
Author: rschlatte
Index: s-xml-rpc/src/xml-rpc.lisp
diff -u s-xml-rpc/src/xml-rpc.lisp:1.3 s-xml-rpc/src/xml-rpc.lisp:1.4
--- s-xml-rpc/src/xml-rpc.lisp:1.3 Sun Jun 13 09:12:03 2004
+++ s-xml-rpc/src/xml-rpc.lisp Thu Jun 17 12:43:11 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $
+;;;; $Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $
;;;;
;;;; This is a Common Lisp implementation of the XML-RPC protocol,
;;;; as documented on the website http://www.xmlrpc.com
@@ -133,7 +133,7 @@
(defun print-xml-rpc-struct (xml-element stream depth)
(declare (ignore depth))
- (format stream "#<XML-RPC-STRUCT~{ ~s~}>" (xml-rpc-struct-alist xml-element)))
+ (format stream "#<XML-RPC-STRUCT~{ ~S~}>" (xml-rpc-struct-alist xml-element)))
(defun get-xml-rpc-struct-member (struct member)
"Get the value of a specific member of an XML-RPC-STRUCT"
@@ -188,9 +188,9 @@
(defun encode-xml-rpc-value (arg stream)
(princ "<value>" stream)
- (cond ((stringp arg)
+ (cond ((or (stringp arg) (symbolp arg))
(princ "<string>" stream)
- (print-string-xml arg stream)
+ (print-string-xml (string arg) stream)
(princ "</string>" stream))
((integerp arg) (format stream "<int>~d</int>" arg))
((floatp arg) (format stream "<double>~f</double>" arg))
@@ -455,70 +455,44 @@
(let ((sym (find-symbol method-name *xml-rpc-package*)))
(if (fboundp sym) sym nil)))
-;;; Introspection methods from http://xmlrpc.usefulinc.com/doc/reserved.html
-;;; To be imported in *xml-rpc-package*.
-
-(defun |system.listMethods| ()
- "List the methods that are available on this server."
- (let ((result nil))
- (do-symbols (sym *xml-rpc-package* (sort result #'string-lessp))
- (when (and (fboundp sym) (valid-xml-rpc-method-name-p (symbol-name sym)))
- (push (symbol-name sym) result)))))
-
-(defun |system.methodSignature| (method-name)
- "Dummy system.methodSignature implementation. There's no way
- to get (and no concept of) required argument types in Lisp, so
- this function always returns nil or errors."
- (let ((method (find-xml-rpc-method method-name)))
- (if method
- ;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to
- ;; return a non-array if the signature is not available
- "n/a"
- (error "Method ~A not found." method-name))))
-
-(defun |system.methodHelp| (method-name)
- "Returns the function documentation for the given method."
- (let ((method (find-xml-rpc-method method-name)))
- (if method
- (or (documentation method 'function) "")
- (error "Method ~A not found." method-name))))
-
-(defun do-one-multicall (call-struct)
- (let ((name (get-xml-rpc-struct-member call-struct :|methodName|))
- (params (get-xml-rpc-struct-member call-struct :|params|)))
- (handler-bind
- ((error #'(lambda (c)
- (format-debug
- (or *xml-rpc-debug-stream* t)
- "A call in a system.multicall failed with ~a~%" c)
- (return-from do-one-multicall
- (xml-literal
- (encode-xml-rpc-fault-value (format nil "~a" c)))))))
- (format-debug (or *xml-rpc-debug-stream* t)
- "system.multicall calling ~a with ~s~%" name params)
- (let ((result (apply *xml-rpc-call-hook* name params)))
- (list result)))))
-
-(defun |system.multicall| (calls)
- "Implement system.multicall; see http://www.xmlrpc.com/discuss/msgReader$1208
- for the specification."
- (mapcar #'do-one-multicall calls))
-
(defun execute-xml-rpc-call (method-name &rest arguments)
"Execute method METHOD-NAME on ARGUMENTS, or raise an error if
no such method exists in *XML-RPC-PACKAGE*"
(let ((method (find-xml-rpc-method method-name)))
(if method
(apply method arguments)
- (error "Method ~A not found." method-name))))
+ ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php
+ ;; -32601 ---> server error. requested method not found
+ (error 'xml-rpc-fault :code -32601
+ :string (format nil "Method ~A not found." method-name)))))
(defun handle-xml-rpc-call (in id)
"Handle an actual call, reading XML from in and returning the
XML-encoded result."
- (handler-bind ((error #'(lambda (c)
- (format-debug (or *xml-rpc-debug-stream* t) "~a call failed with ~a~%" id c)
- (return-from handle-xml-rpc-call
- (encode-xml-rpc-fault (format nil "~a" c))))))
+ ;; Try to conform to
+ ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php
+ (handler-bind ((s-xml:xml-parser-error
+ #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "~a request parsing failed with ~a~%"
+ id c)
+ (return-from handle-xml-rpc-call
+ ;; -32700 ---> parse error. not well formed
+ (encode-xml-rpc-fault (format nil "~a" c) -32700))))
+ (xml-rpc-fault
+ #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "~a call failed with ~a~%" id c)
+ (return-from handle-xml-rpc-call
+ (encode-xml-rpc-fault (xml-rpc-fault-string c)
+ (xml-rpc-fault-code c)))))
+ (error
+ #'(lambda (c)
+ (format-debug (or *xml-rpc-debug-stream* t)
+ "~a call failed with ~a~%" id c)
+ (return-from handle-xml-rpc-call
+ ;; -32603 ---> server error. internal xml-rpc error
+ (encode-xml-rpc-fault (format nil "~a" c) -32603)))))
(let ((call (decode-xml-rpc (debug-stream in))))
(format-debug (or *xml-rpc-debug-stream* t) "~a received call ~s~%" id call)
(let ((result (apply *xml-rpc-call-hook*
@@ -530,7 +504,7 @@
(defun xml-rpc-implementation-version ()
"Identify ourselves"
(concatenate 'string
- "$Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $"
+ "$Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $"
" "
(lisp-implementation-type)
" "
Index: s-xml-rpc/src/package.lisp
diff -u s-xml-rpc/src/package.lisp:1.3 s-xml-rpc/src/package.lisp:1.4
--- s-xml-rpc/src/package.lisp:1.3 Sun Jun 13 09:12:03 2004
+++ s-xml-rpc/src/package.lisp Thu Jun 17 12:43:11 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: package.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $
+;;;; $Id: package.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $
;;;;
;;;; S-XML-RPC package definition
;;;;
@@ -36,13 +36,14 @@
#:*xml-rpc-package* #:*xml-rpc-call-hook*
#:execute-xml-rpc-call #:stop-server
#:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|
- #:|system.multicall|)
+ #:|system.multicall| #:|system.getCapabilities|)
(:documentation "An implementation of the standard XML-RPC protocol for both client and server"))
(defpackage s-xml-rpc-exports
(:use)
(:import-from :s-xml-rpc #:|system.listMethods| #:|system.methodSignature|
- #:|system.methodHelp| #:|system.multicall|)
+ #:|system.methodHelp| #:|system.multicall|
+ #:|system.getCapabilities|)
(:documentation "This package contains the functions callable via xml-rpc."))
;;;; eof
More information about the S-xml-rpc-cvs
mailing list