modules/xmlrpc-client.lsp

   1 ;; @module xmlrpc-client.lsp
   2 ;; @description XMLRPC protocol client routines
   3 ;; @version 0.3 - comments redone for automatic documentation
   4 ;; @author Lutz Mueller, 2005
   5 ;;
   6 ;; <h2>Functions for XML-RPC client</h2>
   7 ;; To use this module include a 'load' statement at the beginning of the program:
   8 ;; <pre>
   9 ;; (load "/usr/share/newlisp/modules/xmlrpc-client.lsp")
  10 ;; </pre>
  11 ;;
  12 ;; The script 'xmlrpc.cgi' together with a webserver or the script
  13 ;; 'xmlrpc-server' for a freestanding XML-RPC server can be used for
  14 ;; testing. Both scripts implement a method 'newLISP.evalString'. This
  15 ;; module contains a client side function for this method.
  16 ;;
  17 ;; For further information on XML-RPC consult
  18 ;; @link http://www.xmlrpc.com/ http://www.xmlrpc.com/ .
  19 ;;
  20 ;; Whenever a connection could be made, method functions will return a response
  21 ;; formatted by the XML-RPC server in XML. If a connection failed the function will
  22 ;; return 'nil' and a call to '(XMLRPC:error)' will return and error text.
  23 ;;
  24 ;; If the XML received cannot be parsed into SXML, the function returns 'nil'
  25 ;; and '(XMLRPC:error)' will return an XML error. SXML is XML transformed into
  26 ;; LISP S-expressions.
  27
  28 ;; If the XML received is syntactically correct but not correctly formatted,
  29 ;; XML garbage is returned or 'nil' is returned and an error message in
  30 ;; '(XMLRPC:error)'.
  31
  32 ;; @syntax (XMLRPC:system.listMethods <str-url>)
  33 ;; @param <str-url> The URL of the XML-RPC server
  34 ;; @return A list or methods supported.
  35 ;; The server at <url> returns a list of methods supported.
  36
  37 ;; @syntax (XMLRPC:system.methodHelp <str-url> <str-method-name>)
  38 ;; @param <str-url> The URL of the XML-RPC server.
  39 ;; @param <method-name> The name of the method to get help for.
  40 ;; @return Help for <str-method-name>
  41 ;; The server at <str-url> returns help for the method in <str-method-name>
  42
  43 ;; @syntax (XMLRPC:system.methodSignatures <str-url> <str-method-name>)
  44 ;; @param <str-url> The URL of the XML-RPC server.
  45 ;; @param <method-name> The name of the method to get the signature for.
  46 ;; @return The signature for a server method.
  47 ;; Gets the calling parameter conventions (signature) for a method
  48 ;; <method-name> at <str-url>.
  49
  50 ;; @syntax (XMLRPC:execute <str-url> <str-xml-request>)
  51 ;; @param <str-url> The URL of the XML-RPC server.
  52 ;; @param <str-xml-request> A XML formatted request.
  53 ;; @return XML formatted server response
  54 ;; This is a generic method for making XML-RPC requests.
  55 ;; The request must be XML formatted correctly by the sender (client).
  56
  57
  58 ;; @syntax (XMLRPC:newLISP.evalString <str-url> <str-expression>)
  59 ;; @param <str-url> The URL of the XML-RPC server.
  60 ;; @param <str-expression> The expresssion to be evaluated in a string.
  61 ;; @return The result of the expression evaluation.
  62 ;; The expression in <str-expression> is encoded in base64 and then
  63 ;; transmitted to the remote server.
  64
  65 ;; @syntax (XMLRPC:error)
  66 ;; @return Error text of last error occured.
  67
  68 (context 'XMLRPC)
  69
  70 (set 'request
  71 [text]<?xml version="1.0"?>
  72 <methodCall>
  73    <methodName>%s</methodName>
  74    <params>
  75       <param>
  76          <value>%s</value>
  77        </param>
  78     </params>
  79 </methodCall>
  80 [/text])
  81
  82 (set 'error-msg "")
  83
  84
  85 ######### extract value(s) from XML-RPC response XML with <params> #############
  86
  87 ; get result data from result structure
  88 ;
  89 (define (get-result-data xml)
  90     (if (starts-with xml "ERR:")
  91         (begin
  92             (set error-msg xml)
  93             (throw nil)))
  94     (xml-type-tags nil nil nil nil)
  95     (set 'sxml (xml-parse xml (+ 1 2 4)))
  96     (if (not sxml) (throw (format "XML error: %s" (first (xml-error)))))
  97
  98     (if (match '(("methodResponse" ("fault" *))) sxml)
  99         (begin
 100             (set 'error-msg
 101                 (let (fault (nth 0 1 1 1 1 2 1 1 sxml)
 102                       text (nth 0 1 1 1 2 2 1 1 sxml))
 103                      (append "Fault " fault ": " text)))
 104                 (throw nil)))
 105
 106     (get-value (nth 0 1 1 1 sxml)))
 107
 108
 109 ; get contents from expr = (value ...)
 110 ;
 111 (define (get-value expr)
 112     (if (empty? expr) nil
 113         (case (nth 1 0 expr)
 114             ("i4" (int (nth 1 1 expr)))
 115             ("int" (int (nth 1 1 expr)))
 116             ("boolean" (if (= "0" (nth 1 1 expr)) nil true))
 117             ("double" (float (nth 1 1 expr)))
 118             ("base64" (base64-dec (nth 1 1 expr)))
 119             ("dateTime.iso8601" (nth 1 1 expr))
 120             ("array" (if (= (nth 1 expr) "array")
 121                          "array" ;; if untagged string "array"
 122                          (get-array (rest (nth 1 1 expr)))) )
 123             ("struct" (get-struct (rest (nth 1 expr))))
 124             ("string" (nth 1 1 expr))
 125             (true (nth 1 expr)))))
 126
 127 ; get contents from expr = ((value ...) (value ...) ...)
 128 ;
 129 (define (get-array expr)
 130     (if (empty? expr)
 131         '()
 132         (cons (get-value (first expr)) (get-array (rest expr)))))
 133
 134
 135 ; get contents from expr = ((member ...) (member) ...)
 136 ;
 137 (define (get-struct expr)
 138     (if (empty? expr)
 139         '()
 140         (cons (get-member (first expr)) (get-struct (rest expr)))))
 141
 142
 143 ; get contents from expr = (member ...)
 144 ;
 145 (define (get-member expr)
 146     (list (nth 1 1 expr) (get-value (last expr))))
 147
 148
 149 ################################ standard system methods #######################
 150
 151 # convert to SXML
 152 (xml-type-tags nil nil nil nil)
 153
 154
 155 # report all methods of XML-RPC server at url
 156 # return method names in a list of strings
 157 #
 158 # (XMLRPC:system.listMethods <url>)
 159 #
 160 (define (system.listMethods url)
 161     (execute url (format request "system.listMethods" "")))
 162
 163
 164 # get help for a methodName at url
 165 # return help in a string
 166 #
 167 # (XMLRPC:system.methodHelp <url> <method-name)
 168 #
 169 (define (system.methodHelp url methodName)
 170     (execute url (format request "system.methodHelp" methodName) ))
 171
 172
 173 # get method signatures of methodName at url
 174 # return ans array of strings
 175 #
 176 # (XMLRPC:system.methodSignatures <url> <method-name>)
 177 #
 178 (define (system.methodSignature url methodName)
 179     (execute url (format request "system.methodSignature" methodName) ))
 180
 181
 182 (define (error) error-msg)
 183
 184
 185 # Execute a method on url with XML formatted request
 186 #
 187 # This is a generic method, but with XML formatted by caller.
 188 #
 189 # (XMLRPC:execute <url> <xml-request>)
 190 #
 191 (define (execute url parameter-XML)
 192     (if (not (catch (begin
 193         (set 'error-msg "")
 194         (set 'xml (post-url url parameter-XML "text/xml"))
 195         (get-result-data xml)) 'result))
 196
 197         (begin (set 'error-msg "Wrong format in XML-RPC") nil)
 198         result))
 199
 200 ######################### newLISP XML-RPC specific methods #####################
 201
 202 # evaluate a newLISP expression in str at newLISP XML-RPC server at url
 203 # return evaluation result in a string
 204 #
 205
 206 (define (newLISP.evalString url str)
 207     (execute url
 208         (format request
 209                 "newLISP.evalString" (append "<base64>" (base64-enc str) "</base64>")))
 210 )
 211
 212 (context MAIN)
 213
 214 # eof
 215