[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/package.lisp
Rudi Schlatte
rschlatte at common-lisp.net
Sun Jun 13 14:14:47 UTC 2004
Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src
In directory common-lisp.net:/tmp/cvs-serv21201/src
Modified Files:
xml-rpc.lisp package.lisp
Log Message:
* src/package.lisp (s-xml-rpc-exports): New package -- don't
export the whole common-lisp package by default ;)
* src/xml-rpc.lisp (*xml-rpc-package*): ... use it.
* src/xml-rpc.lisp (|system.listMethods|)
(|system.methodSignature|, |system.methodHelp|): Added
introspection methods, to be imported in *xml-rpc-package*.
* src/package.lisp (s-xml-rpc): ... export them.
* src/xml-rpc.lisp: Some indentation frobs.
Date: Sun Jun 13 07:14:47 2004
Author: rschlatte
Index: s-xml-rpc/src/xml-rpc.lisp
diff -u s-xml-rpc/src/xml-rpc.lisp:1.1.1.1 s-xml-rpc/src/xml-rpc.lisp:1.2
--- s-xml-rpc/src/xml-rpc.lisp:1.1.1.1 Wed Jun 9 02:02:40 2004
+++ s-xml-rpc/src/xml-rpc.lisp Sun Jun 13 07:14:47 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xml-rpc.lisp,v 1.1.1.1 2004/06/09 09:02:40 scaekenberghe Exp $
+;;;; $Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $
;;;;
;;;; This is a Common Lisp implementation of the XML-RPC protocol,
;;;; as documented on the website http://www.xmlrpc.com
@@ -121,7 +121,7 @@
(let ((pair (assoc member (xml-rpc-struct-alist struct))))
(if pair
(rplacd pair value)
- (push (cons member value) (xml-rpc-struct-alist struct)))
+ (push (cons member value) (xml-rpc-struct-alist struct)))
value))
(defun xml-rpc-struct (&rest args)
@@ -130,9 +130,9 @@
(error "~s must contain an even number of elements" args))
(let (alist)
(loop
- (if (null args)
- (return)
- (push (cons (pop args) (pop args)) alist)))
+ (if (null args)
+ (return)
+ (push (cons (pop args) (pop args)) alist)))
(make-xml-rpc-struct :alist alist)))
(defun xml-rpc-struct-equal (struct1 struct2)
@@ -145,7 +145,7 @@
(unless (equal (get-xml-rpc-struct-member struct2 (car assoc))
(cdr assoc))
(return-from xml-rpc-struct-equal nil)))
- nil))
+ nil))
;;; encoding support
@@ -204,6 +204,9 @@
"Encode an XML-RPC call with name and args as an XML string"
(with-output-to-string (stream)
(princ "<methodCall>" stream)
+ ;; Spec says: The string may only contain identifier characters,
+ ;; upper and lower-case A-Z, the numeric characters, 0-9,
+ ;; underscore, dot, colon and slash.
(format stream "<methodName>~a</methodName>" (string name)) ; assuming name contains no special characters
(when args
(encode-xml-rpc-args args stream))
@@ -299,7 +302,7 @@
(defparameter *xml-rpc-proxy-port* nil
"When not null, an integer specifying the XML-RPC proxy port to use")
-(defparameter *xml-rpc-package* *package*
+(defparameter *xml-rpc-package* (find-package :s-xml-rpc-exports)
"Package for XML-RPC callable functions")
(defparameter *xml-rpc-authorization* nil
@@ -316,13 +319,13 @@
(defun tokens (string &key (start 0) (separators (list #\space #\return #\linefeed #\tab)))
(if (= start (length string))
'()
- (let ((p (position-if #'(lambda (char) (find char separators)) string :start start)))
- (if p
- (if (= p start)
- (tokens string :start (1+ start) :separators separators)
- (cons (subseq string start p)
- (tokens string :start (1+ p) :separators separators)))
- (list (subseq string start))))))
+ (let ((p (position-if #'(lambda (char) (find char separators)) string :start start)))
+ (if p
+ (if (= p start)
+ (tokens string :start (1+ start) :separators separators)
+ (cons (subseq string start p)
+ (tokens string :start (1+ p) :separators separators)))
+ (list (subseq string start))))))
(defun format-header (stream headers)
(mapc #'(lambda (header)
@@ -334,18 +337,18 @@
(defun debug-stream (in)
(if *xml-rpc-debug*
(make-echo-stream in *standard-output*)
- in))
+ in))
;;; client API
(defun xml-rpc-call (encoded &key
- (url *xml-rpc-url*)
- (agent *xml-rpc-agent*)
- (host *xml-rpc-host*)
- (port *xml-rpc-port*)
- (authorization *xml-rpc-authorization*)
- (proxy-host *xml-rpc-proxy-host*)
- (proxy-port *xml-rpc-proxy-port*))
+ (url *xml-rpc-url*)
+ (agent *xml-rpc-agent*)
+ (host *xml-rpc-host*)
+ (port *xml-rpc-port*)
+ (authorization *xml-rpc-authorization*)
+ (proxy-host *xml-rpc-proxy-host*)
+ (proxy-port *xml-rpc-proxy-port*))
"Execute an already encoded XML-RPC call and return the decoded result"
(let ((uri (if proxy-host (format nil "http://~a:~d~a" host port url) url)))
(with-open-socket-stream (connection (if proxy-host proxy-host host)
@@ -375,7 +378,7 @@
(let ((result (decode-xml-rpc (debug-stream connection))))
(if (typep result 'xml-rpc-fault)
(error result)
- (car result))))))
+ (car result))))))
(defun call-xml-rpc-server (server-keywords name &rest args)
"Encode and execute an XML-RPC call with name and args, using the list of server-keywords"
@@ -401,18 +404,64 @@
:port port
:url url))))
+
;;; server API
+(defparameter +xml-rpc-method-characters+
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.:/")
+
+(defun valid-xml-rpc-method-name-p (method-name)
+ (not (find-if-not (lambda (c) (find c +xml-rpc-method-characters+))
+ method-name)))
+
+(defun find-xml-rpc-method (method-name)
+ "Looks for a method with the given name in *xml-rpc-package*,
+ except that colons in the name get converted to hyphens."
+ (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
+ nil
+ (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 execute-xml-rpc-call (method-name &rest arguments)
- "Intern method-name in *xml-rpc-package* and apply that function on arguments"
- (apply (intern method-name *xml-rpc-package*)
- 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))))
(defvar *xml-rpc-call-hook* 'execute-xml-rpc-call
"A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list")
(defun handle-xml-rpc-call (in id)
- "Handle an actual calll, reading XML from in and writing XML to in"
+ "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
@@ -428,7 +477,7 @@
(defun xml-rpc-implementation-version ()
"Identify ourselves"
(concatenate 'string
- "$Id: xml-rpc.lisp,v 1.1.1.1 2004/06/09 09:02:40 scaekenberghe Exp $"
+ "$Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $"
" "
(lisp-implementation-type)
" "
@@ -461,12 +510,12 @@
("Content-Length: ~d" ,(length xml))))
(princ xml connection)
(format-debug (or *xml-rpc-debug-stream* t) "~d sending ~a~%" id xml)))
- (progn
- (format-header connection
- `(("HTTP/1.0 400 Bad Request")
- ("Server: ~a" ,agent)
- ("Connection: close")))
- (format-debug (or *xml-rpc-debug-stream* t) "~d got a bad request~%" id)))
+ (progn
+ (format-header connection
+ `(("HTTP/1.0 400 Bad Request")
+ ("Server: ~a" ,agent)
+ ("Connection: close")))
+ (format-debug (or *xml-rpc-debug-stream* t) "~d got a bad request~%" id)))
(force-output connection)
(close connection))))
Index: s-xml-rpc/src/package.lisp
diff -u s-xml-rpc/src/package.lisp:1.1.1.1 s-xml-rpc/src/package.lisp:1.2
--- s-xml-rpc/src/package.lisp:1.1.1.1 Wed Jun 9 02:02:39 2004
+++ s-xml-rpc/src/package.lisp Sun Jun 13 07:14:47 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: package.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $
+;;;; $Id: package.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $
;;;;
;;;; S-XML-RPC package definition
;;;;
@@ -34,7 +34,14 @@
#:*xml-rpc-proxy-host* #:*xml-rpc-proxy-port* #:*xml-rpc-authorization*
#:*xml-rpc-debug* #:*xml-rpc-debug-stream*
#:*xml-rpc-package* #:*xml-rpc-call-hook*
- #:execute-xml-rpc-call #:stop-server)
+ #:execute-xml-rpc-call #:stop-server
+ #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|)
(: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|)
+ (:documentation "This package contains the functions callable via xml-rpc."))
;;;; eof
More information about the S-xml-rpc-cvs
mailing list