;; @module xmlrpc-client.lsp 
;; @description XMLRPC protocol client routines
;; @version 0.3 - comments redone for automatic documentation
;; @author Lutz Mueller, 2005
;;
;; <h2>Functions for XML-RPC client</h2>
;; To use this module include a 'load' statement at the beginning of the program:
;; <pre>
;; (load "/usr/local/share/newlisp/xmlrpc-client.lsp")
;; </pre>
;;
;; The script 'xmlrpc.cgi' together with a webserver or the script
;; 'xmlrpc-server' for a freestanding XML-RPC server can be used for
;; testing. Both scripts implement a method 'newLISP.evalString'. This
;; module contains a client side function for this method.
;; 
;; For further information on XML-RPC consult 
;; @link http://www.xmlrpc.com/ http://www.xmlrpc.com/ .
;;
;; Whenever a connection could be made, method functions will return a response
;; formatted by the XML-RPC server in XML. If a connection failed the function will
;; return 'nil' and a call to '(XMLRPC:error)' will return and error text.
;;
;; If the XML received cannot be parsed into SXML, the function returns 'nil'
;; and '(XMLRPC:error)' will return an XML error. SXML is XML transformed into
;; LISP S-expressions.

;; If the XML received is syntactically correct but not correctly formatted,
;; XML garbage is returned or 'nil' is returned and an error message in 
;; '(XMLRPC:error)'.

;; @syntax (XMLRPC:system.listMethods <str-url>)                    
;; @param <str-url> The URL of the XML-RPC server
;; @return A list or methods supported.
;; The server at <url> returns a list of methods supported.

;; @syntax (XMLRPC:system.methodHelp <str-url> <str-method-name>)        
;; @param <str-url> The URL of the XML-RPC server.
;; @param <method-name> The name of the method to get help for.
;; @return Help for <str-method-name>
;; The server at <str-url> returns help for the method in <str-method-name>

;; @syntax (XMLRPC:system.methodSignatures <str-url> <str-method-name>) 
;; @param <str-url> The URL of the XML-RPC server.
;; @param <method-name> The name of the method to get the signature for.
;; @return The signature for a server method.
;; Gets the calling parameter conventions (signature) for a method
;; <method-name> at <str-url>.

;; @syntax (XMLRPC:execute <str-url> <str-xml-request>)
;; @param <str-url> The URL of the XML-RPC server.
;; @param <str-xml-request> A XML formatted request.
;; @return XML formatted server response
;; This is a generic method for making XML-RPC requests.
;; The request must be XML formatted correctly by the sender (client).


;; @syntax (XMLRPC:newLISP.evalString <str-url> <str-expression>)
;; @param <str-url> The URL of the XML-RPC server.
;; @param <str-expression> The expresssion to be evaluated in a string.
;; @return The result of the expression evaluation.
;; The expression in <str-expression> is encoded in base64 and then
;; transmitted to the remote server.

;; @syntax (XMLRPC:error)
;; @return Error text of last error occured.

(context 'XMLRPC)

(set 'request
[text]<?xml version="1.0"?>
<methodCall>
   <methodName>%s</methodName>
   <params>
      <param>
         <value>%s</value>
       </param>
    </params>
</methodCall>
[/text])

(set 'error-msg "")


######### extract value(s) from XML-RPC response XML with <params> #############

; get result data from result structure
;
(define (get-result-data xml)
    (if (starts-with xml "ERR:") 
        (begin
            (set error-msg xml)
            (throw nil)))
    (xml-type-tags nil nil nil nil)
    (set 'sxml (xml-parse xml (+ 1 2 4)))   
    (if (not sxml) (throw (format "XML error: %s" (first (xml-error)))))

    (if (match '(("methodResponse" ("fault" *))) sxml) 
        (begin
            (set 'error-msg 
                (let (fault (nth 0 1 1 1 1 2 1 1 sxml) 
                      text (nth 0 1 1 1 2 2 1 1 sxml))
                     (append "Fault " fault ": " text)))
                (throw nil)))

    (get-value (nth 0 1 1 1 sxml)))
   

; get contents from expr = (value ...)
;
(define (get-value expr)
    (if (empty? expr) nil
        (case (nth 1 0 expr)
            ("i4" (int (nth 1 1 expr)))
            ("int" (int (nth 1 1 expr)))
            ("boolean" (if (= "0" (nth 1 1 expr)) nil true))
            ("double" (float (nth 1 1 expr)))
            ("base64" (base64-dec (nth 1 1 expr)))
            ("dateTime.iso8601" (nth 1 1 expr))
            ("array" (if (= (nth 1 expr) "array") 
                         "array" ;; if untagged string "array"
                         (get-array (rest (nth 1 1 expr)))) )
            ("struct" (get-struct (rest (nth 1 expr))))
            ("string" (nth 1 1 expr))
            (true (nth 1 expr)))))

; get contents from expr = ((value ...) (value ...) ...)
;
(define (get-array expr)
    (if (empty? expr) 
        '()
        (cons (get-value (first expr)) (get-array (rest expr)))))


; get contents from expr = ((member ...) (member) ...)
;
(define (get-struct expr)
    (if (empty? expr)
        '()
        (cons (get-member (first expr)) (get-struct (rest expr)))))


; get contents from expr = (member ...)
;
(define (get-member expr)
    (list (nth 1 1 expr) (get-value (last expr))))


################################ standard system methods #######################

# convert to SXML
(xml-type-tags nil nil nil nil)


# report all methods of XML-RPC server at url
# return method names in a list of strings
#
# (XMLRPC:system.listMethods <url>)  
#
(define (system.listMethods url)
    (execute url (format request "system.listMethods" "")))
	

# get help for a methodName at url
# return help in a string
#
# (XMLRPC:system.methodHelp <url> <method-name) 
#
(define (system.methodHelp url methodName)
    (execute url (format request "system.methodHelp" methodName) ))


# get method signatures of methodName at url
# return ans array of strings
#
# (XMLRPC:system.methodSignatures <url> <method-name>) 
#
(define (system.methodSignature url methodName)
    (execute url (format request "system.methodSignature" methodName) ))


(define (error) error-msg)


# Execute a method on url with XML formatted request
#
# This is a generic method, but with XML formatted by caller.
#
# (XMLRPC:execute <url> <xml-request>)
#
(define (execute url parameter-XML)
    (if (not (catch (begin
        (set 'error-msg "")
        (set 'xml (post-url url parameter-XML "text/xml"))
        (get-result-data xml)) 'result))

        (begin (set 'error-msg "Wrong format in XML-RPC") nil)
        result))

######################### newLISP XML-RPC specific methods #####################

# evaluate a newLISP expression in str at newLISP XML-RPC server at url
# return evaluation result in a string 
#

(define (newLISP.evalString url str)
    (execute url 
        (format request 
                "newLISP.evalString" (append "<base64>" (base64-enc str) "</base64>")))
)

(context MAIN)

# eof