;;;; -*- 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