path: root/third-party/s-xml-rpc/src/xml-rpc.lisp

;;;; -*- 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
	  "#<XML-RPC-TIME ~a>"
	  (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 \"~a\" >"
	  (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~{ ~S~}>" (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 "<struct>" stream)
  (dolist (member (xml-rpc-struct-alist struct))
    (write-string "<member>" stream)
    (format stream "<name>~a</name>" (car member)) ; assuming name contains no special characters
    (encode-xml-rpc-value (cdr member) stream)
    (write-string "</member>" stream))
  (write-string "</struct>" stream))

(defun encode-xml-rpc-array (sequence stream)
  (write-string "<array><data>" stream)
  (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence)
  (write-string "</data></array>" stream))

(defun encode-xml-rpc-value (arg stream)
  (write-string "<value>" stream)
  (cond ((or (null arg) (eql arg t))
	 (write-string "<boolean>" stream)
	 (write-string (if arg "1" "0") stream)
	 (write-string "</boolean>" stream))
	((or (stringp arg) (symbolp arg))
	 (write-string "<string>" stream)
	 (print-string-xml (string arg) stream)
	 (write-string "</string>" stream))
	((integerp arg) (format stream "<int>~d</int>" arg))
	((floatp arg) (format stream "<double>~f</double>" arg))
	((and (arrayp arg)
	      (= (array-rank arg) 1)
	      (subtypep (array-element-type arg)
			'(unsigned-byte 8)))
	 (write-string "<base64>" stream)
	 (encode-base64-bytes arg stream)
	 (write-string "</base64>" stream))
	((xml-rpc-time-p arg)
	 (write-string "<dateTime.iso8601>" stream)
	 (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream)
	 (write-string "</dateTime.iso8601>" 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 "</value>" stream))

(defun encode-xml-rpc-args (args stream)
  (write-string "<params>" stream)
  (dolist (arg args)
    (write-string "<param>" stream)
    (encode-xml-rpc-value arg stream)
    (write-string "</param>" stream))
  (write-string "</params>" 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 "<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))
    (write-string "</methodCall>" stream)))

(defun encode-xml-rpc-result (value)
  (with-output-to-string (stream)
    (write-string "<methodResponse>" stream)
    (encode-xml-rpc-args (list value) stream)
    (write-string "</methodResponse>" stream)))

(defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0))
  ;; for system.multicall
  (with-output-to-string (stream)
    (write-string "<struct>" stream)
    (format stream "<member><name>faultCode</name><value><int>~d</int></value></member>" fault-code)
    (write-string "<member><name>faultString</name><value><string>" stream)
    (print-string-xml fault-string stream)
    (write-string "</string></value></member>" stream)
    (write-string "</struct>" stream)))

(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0))
  (with-output-to-string (stream)
    (write-string "<methodResponse><fault><value>" stream)
    (write-string (encode-xml-rpc-fault-value fault-string fault-code) stream)
    (write-string "</value></fault></methodResponse>" 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