examples/xmlrpc.cgi

   1 #!/usr/home/nuevatec/bin/newlisp
   2 #
   3 # xmlrpc.cgi - CGI script to handle XML-RPC requests
   4 #
   5 # This is similar to xmlrpc-server, but stateless as a new
   6 # newLISP process is invoked everytime this script is executed.
   7 # For a XML-RPC server maintaining state run xmlrpc-server.
   8 #
   9 # v.1.0 - 2005-01-14  Lutz Mueller
  10 #
  11 # v.1.1 - 2005-03-20
  12 #       method name for newLISP.evalString was listed wrong
  13 #
  14 # supports the following methods:
  15 #
  16 #    Method                   Return     Parameter
  17 #    ------                   ------     ---------
  18 #    system.listMethods       string     n/a
  19 #    system.methodHelp        string     string
  20 #    system.methodSignature   array      string
  21 #    newLISP.evalString       base64     base64
  22 #
  23 #
  24
  25 (set 'version "1.0")
  26
  27 # formatting templates for responses
  28
  29 (set 'normal-response
  30 [text]<?xml version="1.0"?>
  31 <methodResponse>
  32    <params>
  33       <param>
  34          <value>%s</value>
  35        </param>
  36     </params>
  37 </methodResponse>
  38 [/text])
  39
  40 (set 'fault-response
  41 [text]<?xml version="1.0"?>
  42 <methodResponse>
  43    <fault>
  44       <value>
  45          <struct>
  46             <member>
  47                <name>faultCode</name>
  48                <value><int>%d</int></value>
  49                </member>
  50             <member>
  51                <name>faultString</name>
  52                <value><string>%s</string></value>
  53             </member>
  54          </struct>
  55       </value>
  56    </fault>
  57 </methodResponse>
  58 [/text])
  59
  60
  61 # event handler called when newLISP receives a request
  62
  63 (define (process-post request)
  64     (if (not (catch (handle request) 'page))
  65         (set 'page (format fault-response 0 page)))
  66     (print
  67             "Content-type: text/xml\r\n"
  68             "Content-length: " (length page) "\r\n\r\n"
  69             page))
  70
  71
  72 (define (handle input, XML contentlength methodName params)
  73     (set 'XML "")
  74     (xml-type-tags nil nil nil nil)
  75     (if (not (set 'XML (xml-parse input (+ 1 2 4 8 16))))
  76         (begin
  77             (if (not (xml-error))
  78                 (error 3 "No XML or XML is empty")
  79                 (error 4 (append "XML error: "
  80                                  (first (xml-error))))))
  81
  82         (set 'XML (first XML)))
  83
  84     ; get methodName and parameter section
  85     (set 'm (match '(methodCall (methodName *) *) XML))
  86     (if (not m)
  87         (error 5 "Invalid XML-RPC format"))
  88
  89     (set 'methodName (first (first m)))
  90     (set 'params (last m))
  91
  92     (case methodName
  93         ("newLISP.evalString" (newLISP.evalString params))
  94         ("system.listMethods" (system.listMethods))
  95         ("system.methodHelp" (system.methodHelp params))
  96         ("system.methodSignature" (system.methodSignature params))
  97         (true (error 6 "Method name not known")))
  98 )
  99
 100 (define (error no msg)
 101     (throw (format fault-response no
 102         (append "newLISP XML-RPC v." version " - " msg))))
 103
 104
 105 ######################### remote callable methods ##############################
 106
 107 (define (system.listMethods)
 108 [text]<?xml version="1.0"?>
 109 <methodResponse>
 110    <params>
 111       <param><value><array><data>
 112          <value><string>system.listMethods</string></value>
 113          <value><string>system.methodHelp</string></value>
 114          <value><string>system.methodSignature</string></value>
 115          <value><string>newLISP.evalString</string></value>
 116       </data></array></value></param>
 117     </params>
 118 </methodResponse>
 119 [/text])
 120
 121
 122 (define (system.methodHelp params, methodName)
 123     (set 'methodName (nth 0 1 1 1 1 params))
 124     (case methodName
 125         ("system.listMethods" (format normal-response "Lists all methods implemented."))
 126         ("system.methodHelp" (format normal-response "Documents a method."))
 127         ("system.methodSignature" (format normal-response "Shows the signatures of a method."))
 128         ("newLISP.evalString" (format normal-response "Evaluate a base64 encoded string."))
 129         (true (error 7 "Method name in system.methodHelp not known")))
 130 )
 131
 132 (define (system.methodSignature params)
 133     (set 'methodName (nth 0 1 1 1 1 params))
 134     (case methodName
 135         ("system.listMethods" (format normal-response
 136 "<array>
 137   <data>
 138    <value>
 139     <array>
 140      <data>
 141       <value>array</value>
 142      </data>
 143     </array>
 144    </value>
 145  </data>
 146 </array>"))
 147
 148         ("system.methodHelp" (format normal-response
 149 "<array>
 150   <data>
 151    <value>
 152     <array>
 153      <data>
 154       <value>string</value>
 155       <value>string</value>
 156      </data>
 157     </array>
 158    </value>
 159  </data>
 160 </array>"))
 161
 162         ("system.methodSignature" (format normal-response
 163 "<array>
 164   <data>
 165    <value>
 166     <array>
 167      <data>
 168       <value>array</value>
 169       <value>string</value>
 170      </data>
 171     </array>
 172    </value>
 173  </data>
 174 </array>"))
 175
 176         ("newLISP.evalString" (format normal-response
 177 "<array>
 178   <data>
 179    <value>
 180     <array>
 181      <data>
 182       <value>base64</value>
 183       <value>base64</value>
 184      </data>
 185     </array>
 186    </value>
 187  </data>
 188 </array>"))
 189
 190         (true (error 7 "Method name in system.methodSignature not known")))
 191 )
 192
 193 (define (newLISP.evalString params, m, result)
 194     (set 'm (match '((params (param (value (base64 *))))) params))
 195     (if (not m)
 196         (error 8 "Invalid format for method newLISP.evalString")
 197         (set 'result
 198             (string (eval-string (base64-dec (first (first m))) (error-text))))
 199 ;;              "This function has been disabled in this demo for security reasons.")
 200         (format normal-response
 201             (append "<base64>" (base64-enc result) "</base64>")) )
 202 )
 203
 204
 205 ########################### MAIN ENTRY POINT #######################
 206
 207 (set 'input (read-line))
 208
 209 (if (not input)
 210     (print
 211         "Content-type: text/html\r\n\r\n"
 212         "<h2>newLISP XML-RPC v." version
 213         ": not a valid XML-RPC request</h2>")
 214     (begin
 215         (while (read-line) (write-buffer input (current-line)))
 216         (process-post input))
 217 )
 218
 219
 220 (exit)
 221
 222
 223 # eof