diff options
Diffstat (limited to 'third-party/s-xml-rpc/src/extensions.lisp')
| -rw-r--r-- | third-party/s-xml-rpc/src/extensions.lisp | 107 |
1 files changed, 107 insertions, 0 deletions
diff --git a/third-party/s-xml-rpc/src/extensions.lisp b/third-party/s-xml-rpc/src/extensions.lisp new file mode 100644 index 0000000..fa961e2 --- /dev/null +++ b/third-party/s-xml-rpc/src/extensions.lisp @@ -0,0 +1,107 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: extensions.lisp,v 1.1 2004-06-17 19:43:11 rschlatte Exp $ +;;;; +;;;; Extensions for xml-rpc: +;;;; +;;;; Server introspection: +;;;; http://xmlrpc.usefulinc.com/doc/reserved.html +;;;; +;;;; Multicall: +;;;; http://www.xmlrpc.com/discuss/msgReader$1208 +;;;; +;;;; Capabilities: +;;;; http://groups.yahoo.com/group/xml-rpc/message/2897 +;;;; +;;;; +;;;; Copyright (C) 2004 Rudi Schlatte +;;;; +;;;; You are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser General Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :s-xml-rpc) + +;;; Introspection + +(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)))) + +;;; system.multicall + +(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 + ((xml-rpc-fault + #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "Call to ~A in system.multicall failed with ~a~%" + name c) + (return-from do-one-multicall + (xml-literal + (encode-xml-rpc-fault-value (xml-rpc-fault-string c) + (xml-rpc-fault-code c)))))) + (error + #'(lambda (c) + (format-debug + (or *xml-rpc-debug-stream* t) + "Call to ~A in system.multicall failed with ~a~%" name c) + (return-from do-one-multicall + (xml-literal + (encode-xml-rpc-fault-value + ;; -32603 ---> server error. internal xml-rpc error + (format nil "~a" c) -32603)))))) + (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)) + +;;; system.getCapabilities + +(defun |system.getCapabilities| () + "Get a list of supported capabilities; see + http://groups.yahoo.com/group/xml-rpc/message/2897 for the + specification." + (let ((capabilities + '("xmlrpc" ("specUrl" "http://www.xmlrpc.com/spec" + "specVersion" 1) + "introspect" ("specUrl" "http://xmlrpc.usefulinc.com/doc/reserved.html" + "specVersion" 1) + "multicall" ("specUrl" "http://www.xmlrpc.com/discuss/msgReader$1208" + "specVersion" 1) + "faults_interop" ("specUrl" "http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php" + "specVersion" 20010516)))) + (apply #'xml-rpc-struct + (loop for (name description) on capabilities by #'cddr + collecting name + collecting (apply #'xml-rpc-struct description))))) + +;;;; eof |