From ddb83b1fb2d305e0c06fc067d82d6bab5458b0fd Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Fri, 30 Oct 2009 20:52:07 +0100 Subject: Add third-party XML processing libraries. Ignore-this: 5ca28497555bf944858ca2f58bc8a62b darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c --- third-party/s-xml-rpc/src/xml-rpc.lisp | 586 +++++++++++++++++++++++++++++++++ 1 file changed, 586 insertions(+) create mode 100644 third-party/s-xml-rpc/src/xml-rpc.lisp (limited to 'third-party/s-xml-rpc/src/xml-rpc.lisp') diff --git a/third-party/s-xml-rpc/src/xml-rpc.lisp b/third-party/s-xml-rpc/src/xml-rpc.lisp new file mode 100644 index 0000000..b65d2c0 --- /dev/null +++ b/third-party/s-xml-rpc/src/xml-rpc.lisp @@ -0,0 +1,586 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: xml-rpc.lisp,v 1.11 2008-02-15 15:42:40 scaekenberghe Exp $ +;;;; +;;;; This is a Common Lisp implementation of the XML-RPC protocol, +;;;; as documented on the website http://www.xmlrpc.com +;;;; This implementation includes both a client and server part. +;;;; A Base64 encoder/decoder and a minimal XML parser are required. +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; 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) + +;;; conditions + +(define-condition xml-rpc-condition (error) + () + (:documentation "Parent condition for all conditions thrown by the XML-RPC package")) + +(define-condition xml-rpc-fault (xml-rpc-condition) + ((code :initarg :code :reader xml-rpc-fault-code) + (string :initarg :string :reader xml-rpc-fault-string)) + (:report (lambda (condition stream) + (format stream + "XML-RPC fault with message '~a' and code ~d." + (xml-rpc-fault-string condition) + (xml-rpc-fault-code condition)))) + (:documentation "This condition is thrown when the XML-RPC server returns a fault")) + +(setf (documentation 'xml-rpc-fault-code 'function) "Get the code from an XML-RPC fault") +(setf (documentation 'xml-rpc-fault-string 'function) "Get the string from an XML-RPC fault") + +(define-condition xml-rpc-error (xml-rpc-condition) + ((place :initarg :code :reader xml-rpc-error-place) + (data :initarg :data :reader xml-rpc-error-data)) + (:report (lambda (condition stream) + (format stream + "XML-RPC error ~a at ~a." + (xml-rpc-error-data condition) + (xml-rpc-error-place condition)))) + (:documentation "This condition is thrown when an XML-RPC protocol error occurs")) + +(setf (documentation 'xml-rpc-error-place 'function) + "Get the place from an XML-RPC error" + (documentation 'xml-rpc-error-data 'function) + "Get the data from an XML-RPC error") + +;;; whitespace handling support + +(defparameter +whitespace-characters+ + '(#\Tab #\Space #\Page #\Return #\Newline #\Linefeed) + "The list of characters that we consider as whitespace") + +(defun whitespace-char? (char) + "Return t when char is considered whitespace" + (member char +whitespace-characters+ :test #'char=)) + +(defun whitespace-string? (str) + "Return t when str consists of nothing but whitespace characters" + (every #'whitespace-char? str)) + +;;; iso8601 support (the xml-rpc variant) + +(defun universal-time->iso8601 (time &optional (stream nil)) + "Convert a Common Lisp universal time to a string in the XML-RPC variant of ISO8601" + (multiple-value-bind (second minute hour date month year) + (decode-universal-time time) + (format stream + "~d~2,'0d~2,'0dT~2,'0d:~2,'0d:~2,'0d" + year + month + date + hour + minute + second))) + +(defun iso8601->universal-time (string) + "Convert string in the XML-RPC variant of ISO8601 to a Common Lisp universal time" + (let (year month date (hour 0) (minute 0) (second 0)) + (setf string (string-trim +whitespace-characters+ string)) + (when (< (length string) 9) + (error "~s is to short to represent an iso8601" string)) + (setf year (parse-integer string :start 0 :end 4) + month (parse-integer string :start 4 :end 6) + date (parse-integer string :start 6 :end 8)) + (when (and (>= (length string) 17) (char= #\T (char string 8))) + (setf hour (parse-integer string :start 9 :end 11) + minute (parse-integer string :start 12 :end 14) + second (parse-integer string :start 15 :end 17))) + (encode-universal-time second minute hour date month year))) + +(defstruct (xml-rpc-time (:print-function print-xml-rpc-time)) + "A wrapper around a Common Lisp universal time to be interpreted as an XML-RPC-TIME" + universal-time) + +(setf (documentation 'xml-rpc-time-p 'function) + "Return T when the argument is an XML-RPC time" + (documentation 'xml-rpc-time-universal-time 'function) + "Return the universal time from an XML-RPC time") + +(defun print-xml-rpc-time (xml-rpc-time stream depth) + (declare (ignore depth)) + (format stream + "#" + (universal-time->iso8601 (xml-rpc-time-universal-time xml-rpc-time)))) + +(defun xml-rpc-time (&optional (universal-time (get-universal-time))) + "Create a new XML-RPC-TIME struct with the universal time specified, defaulting to now" + (make-xml-rpc-time :universal-time universal-time)) + +;;; a wrapper for literal strings, where escaping #\< and #\& is not +;;; desired + +(defstruct (xml-literal (:print-function print-xml-literal)) + "A wrapper around a Common Lisp string that will be sent over + the wire unescaped" + content) + +(setf (documentation 'xml-literal-p 'function) + "Return T when the argument is an unescaped xml string" + (documentation 'xml-literal-content 'function) + "Return the content of a literal xml string") + +(defun print-xml-literal (xml-literal stream depth) + (declare (ignore depth)) + (format stream + "#" + (xml-literal-content xml-literal))) + +(defun xml-literal (content) + "Create a new XML-LITERAL struct with the specified content." + (make-xml-literal :content content)) + +;;; an extra datatype for xml-rpc structures (associative maps) + +(defstruct (xml-rpc-struct (:print-function print-xml-rpc-struct)) + "An XML-RPC-STRUCT is an associative map of member names and values" + alist) + +(setf (documentation 'xml-rpc-struct-p 'function) + "Return T when the argument is an XML-RPC struct" + (documentation 'xml-rpc-struct-alist 'function) + "Return the alist of member names and values from an XML-RPC struct") + +(defun print-xml-rpc-struct (xml-element stream depth) + (declare (ignore depth)) + (format stream "#" (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" + (cdr (assoc member (xml-rpc-struct-alist struct)))) + +(defun (setf get-xml-rpc-struct-member) (value struct member) + "Set the value of a specific member of an XML-RPC-STRUCT" + (let ((pair (assoc member (xml-rpc-struct-alist struct)))) + (if pair + (rplacd pair value) + (push (cons member value) (xml-rpc-struct-alist struct))) + value)) + +(defun xml-rpc-struct (&rest args) + "Create a new XML-RPC-STRUCT from the arguments: alternating member names and values" + (unless (evenp (length args)) + (error "~s must contain an even number of elements" args)) + (let (alist) + (loop + (if (null args) + (return) + (push (cons (pop args) (pop args)) alist))) + (make-xml-rpc-struct :alist alist))) + +(defun xml-rpc-struct-equal (struct1 struct2) + "Compare two XML-RPC-STRUCTs for equality" + (if (and (xml-rpc-struct-p struct1) + (xml-rpc-struct-p struct2) + (= (length (xml-rpc-struct-alist struct1)) + (length (xml-rpc-struct-alist struct2)))) + (dolist (assoc (xml-rpc-struct-alist struct1) t) + (unless (equal (get-xml-rpc-struct-member struct2 (car assoc)) + (cdr assoc)) + (return-from xml-rpc-struct-equal nil))) + nil)) + +;;; encoding support + +(defun encode-xml-rpc-struct (struct stream) + (write-string "" stream) + (dolist (member (xml-rpc-struct-alist struct)) + (write-string "" stream) + (format stream "~a" (car member)) ; assuming name contains no special characters + (encode-xml-rpc-value (cdr member) stream) + (write-string "" stream)) + (write-string "" stream)) + +(defun encode-xml-rpc-array (sequence stream) + (write-string "" stream) + (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence) + (write-string "" stream)) + +(defun encode-xml-rpc-value (arg stream) + (write-string "" stream) + (cond ((or (null arg) (eql arg t)) + (write-string "" stream) + (write-string (if arg "1" "0") stream) + (write-string "" stream)) + ((or (stringp arg) (symbolp arg)) + (write-string "" stream) + (print-string-xml (string arg) stream) + (write-string "" stream)) + ((integerp arg) (format stream "~d" arg)) + ((floatp arg) (format stream "~f" arg)) + ((and (arrayp arg) + (= (array-rank arg) 1) + (subtypep (array-element-type arg) + '(unsigned-byte 8))) + (write-string "" stream) + (encode-base64-bytes arg stream) + (write-string "" stream)) + ((xml-rpc-time-p arg) + (write-string "" stream) + (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream) + (write-string "" stream)) + ((xml-literal-p arg) + (write-string (xml-literal-content arg) stream)) + ((or (listp arg) (vectorp arg)) (encode-xml-rpc-array arg stream)) + ((xml-rpc-struct-p arg) (encode-xml-rpc-struct arg stream)) + ;; add generic method call + (t (error "cannot encode ~s" arg))) + (write-string "" stream)) + +(defun encode-xml-rpc-args (args stream) + (write-string "" stream) + (dolist (arg args) + (write-string "" stream) + (encode-xml-rpc-value arg stream) + (write-string "" stream)) + (write-string "" stream)) + +(defun encode-xml-rpc-call (name &rest args) + "Encode an XML-RPC call with name and args as an XML string" + (with-output-to-string (stream) + (write-string "" 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 "~a" (string name)) ; assuming name contains no special characters + (when args + (encode-xml-rpc-args args stream)) + (write-string "" stream))) + +(defun encode-xml-rpc-result (value) + (with-output-to-string (stream) + (write-string "" stream) + (encode-xml-rpc-args (list value) stream) + (write-string "" stream))) + +(defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0)) + ;; for system.multicall + (with-output-to-string (stream) + (write-string "" stream) + (format stream "faultCode~d" fault-code) + (write-string "faultString" stream) + (print-string-xml fault-string stream) + (write-string "" stream) + (write-string "" stream))) + +(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0)) + (with-output-to-string (stream) + (write-string "" stream) + (write-string (encode-xml-rpc-fault-value fault-string fault-code) stream) + (write-string "" stream))) + +;;; decoding support + +(defun decode-xml-rpc-new-element (name attributes seed) + (declare (ignore seed name attributes)) + '()) + +(defun decode-xml-rpc-finish-element (name attributes parent-seed seed) + (declare (ignore attributes)) + (cons (case name + ((:|int| :|i4|) (parse-integer seed)) + (:|double| (let ((*read-eval* nil) + (*read-default-float-format* 'double-float)) + (read-from-string seed))) + (:|boolean| (= 1 (parse-integer seed))) + (:|string| (if (null seed) "" seed)) + (:|dateTime.iso8601| (xml-rpc-time (iso8601->universal-time seed))) + (:|base64| (if (null seed) + (make-array 0 :element-type '(unsigned-byte 8)) + (with-input-from-string (in seed) + (decode-base64-bytes in)))) + (:|array| (car seed)) + (:|data| (unless (stringp seed) (nreverse seed))) + (:|value| (cond ((stringp seed) seed) + ((null seed) "") + (t (car seed)))) + (:|struct| (make-xml-rpc-struct :alist seed)) + (:|member| (cons (cadr seed) (car seed))) + (:|name| (intern seed :keyword)) + (:|params| (nreverse seed)) + (:|param| (car seed)) + (:|fault| (make-condition 'xml-rpc-fault + :string (get-xml-rpc-struct-member (car seed) :|faultString|) + :code (get-xml-rpc-struct-member (car seed) :|faultCode|))) + (:|methodName| seed) + (:|methodCall| (let ((pair (nreverse seed))) + (cons (car pair) (cadr pair)))) + (:|methodResponse| (car seed))) + parent-seed)) + +(defun decode-xml-rpc-text (string seed) + (declare (ignore seed)) + string) + +(defun decode-xml-rpc (stream) + (car (start-parse-xml stream + (make-instance 'xml-parser-state + :new-element-hook #'decode-xml-rpc-new-element + :finish-element-hook #'decode-xml-rpc-finish-element + :text-hook #'decode-xml-rpc-text)))) + +;;; networking basics + +(defparameter *xml-rpc-host* "localhost" + "String naming the default XML-RPC host to use") + +(defparameter *xml-rpc-port* 80 + "Integer specifying the default XML-RPC port to use") + +(defparameter *xml-rpc-url* "/RPC2" + "String specifying the default XML-RPC URL to use") + +(defparameter *xml-rpc-agent* (concatenate 'string + (lisp-implementation-type) + " " + (lisp-implementation-version)) + "String specifying the default XML-RPC agent to include in server responses") + +(defvar *xml-rpc-debug* nil + "When T the XML-RPC client and server part will be more verbose about their protocol") + +(defvar *xml-rpc-debug-stream* nil + "When not nil it specifies where debugging output should be written to") + +(defparameter *xml-rpc-proxy-host* nil + "When not null, a string naming the XML-RPC proxy host to use") + +(defparameter *xml-rpc-proxy-port* nil + "When not null, an integer specifying the XML-RPC proxy port to use") + +(defparameter *xml-rpc-package* (find-package :s-xml-rpc-exports) + "Package for XML-RPC callable functions") + +(defparameter *xml-rpc-authorization* nil + "When not null, a string to be used as Authorization header") + +(defun format-debug (&rest args) + (when *xml-rpc-debug* + (apply #'format args))) + +(defparameter +crlf+ (make-array 2 + :element-type 'character + :initial-contents '(#\return #\linefeed))) + +(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)))))) + +(defun format-header (stream headers) + (mapc #'(lambda (header) + (cond ((null (rest header)) (write-string (first header) stream) (write-string +crlf+ stream)) + ((second header) (apply #'format stream header) (write-string +crlf+ stream)))) + headers) + (write-string +crlf+ stream)) + +(defun debug-stream (in) + (if *xml-rpc-debug* + (make-echo-stream in *standard-output*) + 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*)) + "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-stream (connection (s-sysdeps:open-socket-stream (if proxy-host proxy-host host) + (if proxy-port proxy-port port))) + (format-debug (or *xml-rpc-debug-stream* t) "POST ~a HTTP/1.0~%Host: ~a:~d~%" uri host port) + (format-header connection `(("POST ~a HTTP/1.0" ,uri) + ("User-Agent: ~a" ,agent) + ("Host: ~a:~d" ,host ,port) + ("Authorization: ~a" ,authorization) + ("Content-Type: text/xml") + ("Content-Length: ~d" ,(length encoded)))) + (write-string encoded connection) + (finish-output connection) + (format-debug (or *xml-rpc-debug-stream* t) "Sending ~a~%~%" encoded) + (let ((header (read-line connection nil nil))) + (when (null header) (error "no response from server")) + (format-debug (or *xml-rpc-debug-stream* t) "~a~%" header) + (setf header (tokens header)) + (unless (and (>= (length header) 3) + (string-equal (second header) "200") + (string-equal (third header) "OK")) + (error "http-error:~{ ~a~}" header))) + (do ((line (read-line connection nil nil) + (read-line connection nil nil))) + ((or (null line) (<= (length line) 1))) + (format-debug (or *xml-rpc-debug-stream* t) "~a~%" line)) + (let ((result (decode-xml-rpc (debug-stream connection)))) + (if (typep result 'xml-rpc-fault) + (error 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" + (apply #'xml-rpc-call + (cons (apply #'encode-xml-rpc-call (cons name args)) + server-keywords))) + +(defun describe-server (&key (host *xml-rpc-host*) (port *xml-rpc-port*) (url *xml-rpc-url*)) + "Tries to describe a remote server using system.* methods" + (dolist (method (xml-rpc-call (encode-xml-rpc-call "system.listMethods") + :host host + :port port + :url url)) + (format t + "Method ~a ~a~%~a~%~%" + method + (xml-rpc-call (encode-xml-rpc-call "system.methodSignature" method) + :host host + :port port + :url url) + (xml-rpc-call (encode-xml-rpc-call "system.methodHelp" method) + :host host + :port port + :url url)))) + + +;;; server API + +(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") + +(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*. + Returns the symbol named METHOD-NAME if it exists and is + fbound, or NIL if not." + (let ((sym (find-symbol method-name *xml-rpc-package*))) + (if (fboundp sym) sym nil))) + +(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) + ;; 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." + ;; 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* + (first call) + (rest call)))) + (format-debug (or *xml-rpc-debug-stream* t) "~a call result is ~s~%" id result) + (encode-xml-rpc-result result))))) + +(defun xml-rpc-implementation-version () + "Identify ourselves" + (concatenate 'string + "$Id: xml-rpc.lisp,v 1.11 2008-02-15 15:42:40 scaekenberghe Exp $" + " " + (lisp-implementation-type) + " " + (lisp-implementation-version))) + +(defun xml-rpc-server-connection-handler (connection id agent url) + "Handle an incoming connection, doing both all HTTP and XML-RPC stuff" + (handler-bind ((error #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "xml-rpc server connection handler failed with ~a~%" c) + (error c) + (return-from xml-rpc-server-connection-handler nil)))) + (let ((header (read-line connection nil nil))) + (when (null header) (error "no request from client")) + (setf header (tokens header)) + (if (and (>= (length header) 3) + (string-equal (first header) "POST") + (string-equal (second header) url)) + (progn + (do ((line (read-line connection nil nil) + (read-line connection nil nil))) + ((or (null line) (<= (length line) 1))) + (format-debug (or *xml-rpc-debug-stream* t) "~d ~a~%" id line)) + (let ((xml (handle-xml-rpc-call connection id))) + (format-header connection + `(("HTTP/1.0 200 OK") + ("Server: ~a" ,agent) + ("Connection: close") + ("Content-Type: text/xml") + ("Content-Length: ~d" ,(length xml)))) + (write-string 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))) + (force-output connection) + (close connection)))) + +(defparameter *counter* 0 "Unique ID for incoming connections") + +(defun start-xml-rpc-server (&key (port *xml-rpc-port*) (url *xml-rpc-url*) (agent *xml-rpc-agent*)) + "Start an XML-RPC server in a separate process" + (s-sysdeps:start-standard-server + :name (format nil "xml-rpc server ~a:~d" url port) + :port port + :connection-handler #'(lambda (client-stream) + (let ((id (incf *counter*))) + (format-debug (or *xml-rpc-debug-stream* t) "spawned connection handler ~d~%" id) + (s-sysdeps:run-process (format nil "xml-rpc-server-connection-handler-~d" id) + #'xml-rpc-server-connection-handler + client-stream + id + agent + url))))) + +;;;; eof -- cgit v1.2.3