blob: fa961e24945a50a8a0f0aa1ffd38f8f7aab7d1cb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
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
|
