aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMichael Albinus2011-02-16 10:25:37 +0100
committerMichael Albinus2011-02-16 10:25:37 +0100
commit16d2ff891446b821ef348d451f73683a0d3a21f6 (patch)
treed35b6d2ade22d67ad3c04121a222d8db92966efd
parentc6cefd36106ddade8fc65fc074221132357428ff (diff)
downloademacs-16d2ff891446b821ef348d451f73683a0d3a21f6.tar.gz
emacs-16d2ff891446b821ef348d451f73683a0d3a21f6.zip
* net/soap-client.el:
* net/soap-inspect.el: New files.
Diffstat
-rw-r--r--lisp/ChangeLog5
-rw-r--r--lisp/net/soap-client.el1694
-rw-r--r--lisp/net/soap-inspect.el352
3 files changed, 2051 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 65453b44c22..5d346845e58 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
12011-02-16 Alex Harsanyi <AlexHarsanyi@gmail.com>
2
3 * net/soap-client.el:
4 * net/soap-inspect.el: New files.
5
12011-02-16 Leo <sdl.web@gmail.com> 62011-02-16 Leo <sdl.web@gmail.com>
2 7
3 * dired-x.el (dired-mode-map, dired-extra-startup): 8 * dired-x.el (dired-mode-map, dired-extra-startup):
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
new file mode 100644
index 00000000000..c43c17dc9ef
--- /dev/null
+++ b/lisp/net/soap-client.el
@@ -0,0 +1,1694 @@
1;;;; soap.el -- Access SOAP web services from Emacs
2
3;; Copyright (C) 2009-2011 Alex Harsanyi <AlexHarsanyi@gmail.com>
4
5;; This program is free software: you can redistribute it and/or modify
6;; it under the terms of the GNU General Public License as published by
7;; the Free Software Foundation, either version 3 of the License, or
8;; (at your option) any later version.
9
10;; This program is distributed in the hope that it will be useful,
11;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13;; GNU General Public License for more details.
14
15;; You should have received a copy of the GNU General Public License
16;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17
18;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com)
19;; Created: December, 2009
20;; Keywords: soap, web-services
21;; Homepage: http://code.google.com/p/emacs-soap-client
22;;
23
24;;; Commentary:
25;;
26;; To use the SOAP client, you first need to load the WSDL document for the
27;; service you want to access, using `soap-load-wsdl-from-url'. A WSDL
28;; document describes the available operations of the SOAP service, how their
29;; parameters and responses are encoded. To invoke operations, you use the
30;; `soap-invoke' method passing it the WSDL, the service name, the operation
31;; you wish to invoke and any required parameters.
32;;
33;; Idealy, the service you want to access will have some documentation about
34;; the operations it supports. If it does not, you can try using
35;; `soap-inspect' to browse the WSDL document and see the available operations
36;; and their parameters.
37;;
38
39;;; Code:
40
41(eval-when-compile (require 'cl))
42
43(require 'xml)
44(require 'warnings)
45(require 'url)
46(require 'url-http)
47(require 'url-util)
48(require 'mm-decode)
49
50(defsubst soap-warning (message &rest args)
51 "Display a warning MESSAGE with ARGS, using the 'soap-client warning type."
52 (display-warning 'soap-client (apply 'format message args) :warning))
53
54(defgroup soap-client nil
55 "Access SOAP web services from Emacs."
56 :group 'tools)
57
58;;;; Support for parsing XML documents with namespaces
59
60;; XML documents with namespaces are difficult to parse because the names of
61;; the nodes depend on what "xmlns" aliases have been defined in the document.
62;; To work with such documents, we introduce a translation layer between a
63;; "well known" namespace tag and the local namespace tag in the document
64;; being parsed.
65
66(defconst *soap-well-known-xmlns*
67 '(("apachesoap" . "http://xml.apache.org/xml-soap")
68 ("soapenc" . "http://schemas.xmlsoap.org/soap/encoding/")
69 ("wsdl" . "http://schemas.xmlsoap.org/wsdl/")
70 ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/")
71 ("xsd" . "http://www.w3.org/2001/XMLSchema")
72 ("xsi" . "http://www.w3.org/2001/XMLSchema-instance")
73 ("soap" . "http://schemas.xmlsoap.org/soap/envelope/")
74 ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/")
75 ("http" . "http://schemas.xmlsoap.org/wsdl/http/")
76 ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/"))
77 "A list of well known xml namespaces and their aliases.")
78
79(defvar *soap-local-xmlns* nil
80 "A list of local namespace aliases.
81This is a dynamically bound variable, controlled by
82`soap-with-local-xmlns'.")
83
84(defvar *soap-default-xmlns* nil
85 "The default XML namespaces.
86Names in this namespace will be unqualified. This is a
87dynamically bound variable, controlled by
88`soap-with-local-xmlns'")
89
90(defvar *soap-target-xmlns* nil
91 "The target XML namespace.
92New XSD elements will be defined in this namespace, unless they
93are fully qualified for a different namespace. This is a
94dynamically bound variable, controlled by
95`soap-with-local-xmlns'")
96
97(defun soap-wk2l (well-known-name)
98 "Return local variant of WELL-KNOWN-NAME.
99This is done by looking up the namespace in the
100`*soap-well-known-xmlns*' table and resolving the namespace to
101the local name based on the current local translation table
102`*soap-local-xmlns*'. See also `soap-with-local-xmlns'."
103 (let ((wk-name-1 (if (symbolp well-known-name)
104 (symbol-name well-known-name)
105 well-known-name)))
106 (cond
107 ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1)
108 (let ((ns (match-string 1 wk-name-1))
109 (name (match-string 2 wk-name-1)))
110 (let ((namespace (cdr (assoc ns *soap-well-known-xmlns*))))
111 (cond ((equal namespace *soap-default-xmlns*)
112 ;; Name is unqualified in the default namespace
113 (if (symbolp well-known-name)
114 (intern name)
115 name))
116 (t
117 (let* ((local-ns (car (rassoc namespace *soap-local-xmlns*)))
118 (local-name (concat local-ns ":" name)))
119 (if (symbolp well-known-name)
120 (intern local-name)
121 local-name)))))))
122 (t well-known-name))))
123
124(defun soap-l2wk (local-name)
125 "Convert LOCAL-NAME into a well known name.
126The namespace of LOCAL-NAME is looked up in the
127`*soap-well-known-xmlns*' table and a well known namespace tag is
128used in the name.
129
130nil is returned if there is no well-known namespace for the
131namespace of LOCAL-NAME."
132 (let ((l-name-1 (if (symbolp local-name)
133 (symbol-name local-name)
134 local-name))
135 namespace name)
136 (cond
137 ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1)
138 (setq name (match-string 2 l-name-1))
139 (let ((ns (match-string 1 l-name-1)))
140 (setq namespace (cdr (assoc ns *soap-local-xmlns*)))
141 (unless namespace
142 (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns))))
143 (t
144 (setq name l-name-1)
145 (setq namespace *soap-default-xmlns*)))
146
147 (if namespace
148 (let ((well-known-ns (car (rassoc namespace *soap-well-known-xmlns*))))
149 (if well-known-ns
150 (let ((well-known-name (concat well-known-ns ":" name)))
151 (if (symbol-name local-name)
152 (intern well-known-name)
153 well-known-name))
154 (progn
155 ;; (soap-warning "soap-l2wk(%s): namespace %s has no well-known tag"
156 ;; local-name namespace)
157 nil)))
158 ;; if no namespace is defined, just return the unqualified name
159 name)))
160
161
162(defun soap-l2fq (local-name &optional use-tns)
163 "Convert LOCAL-NAME into a fully qualified name.
164A fully qualified name is a cons of the namespace name and the
165name of the element itself. For example \"xsd:string\" is
166converted to \(\"http://www.w3.org/2001/XMLSchema\" . \"string\"
167\).
168
169The USE-TNS argument specifies what to do when LOCAL-NAME has no
170namespace tag. If USE-TNS is non-nil, the `*soap-target-xmlns*'
171will be used as the element's namespace, otherwise
172`*soap-default-xmlns*' will be used.
173
174This is needed because different parts of a WSDL document can use
175different namespace aliases for the same element."
176 (let ((local-name-1 (if (symbolp local-name)
177 (symbol-name local-name)
178 local-name)))
179 (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1)
180 (let ((ns (match-string 1 local-name-1))
181 (name (match-string 2 local-name-1)))
182 (let ((namespace (cdr (assoc ns *soap-local-xmlns*))))
183 (if namespace
184 (cons namespace name)
185 (error "Soap-l2fq(%s): unknown alias %s" local-name ns)))))
186 (t
187 (cons (if use-tns
188 *soap-target-xmlns*
189 *soap-default-xmlns*)
190 local-name)))))
191
192(defun soap-extract-xmlns (node &optional xmlns-table)
193 "Return a namespace alias table for NODE by extending XMLNS-TABLE."
194 (let (xmlns default-ns target-ns)
195 (dolist (a (xml-node-attributes node))
196 (let ((name (symbol-name (car a)))
197 (value (cdr a)))
198 (cond ((string= name "targetNamespace")
199 (setq target-ns value))
200 ((string= name "xmlns")
201 (setq default-ns value))
202 ((string-match "^xmlns:\\(.*\\)$" name)
203 (push (cons (match-string 1 name) value) xmlns)))))
204
205 (let ((tns (assoc "tns" xmlns)))
206 (cond ((and tns target-ns)
207 ;; If a tns alias is defined for this node, it must match the target
208 ;; namespace.
209 (unless (equal target-ns (cdr tns))
210 (soap-warning "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch"
211 (xml-node-name node))))
212 ((and tns (not target-ns))
213 (setq target-ns (cdr tns)))
214 ((and (not tns) target-ns)
215 ;; a tns alias was not defined in this node. See if the node has
216 ;; a "targetNamespace" attribute and add an alias to this. Note
217 ;; that we might override an existing tns alias in XMLNS-TABLE,
218 ;; but that is intended.
219 (push (cons "tns" target-ns) xmlns))))
220
221 (list default-ns target-ns (append xmlns xmlns-table))))
222
223(defmacro soap-with-local-xmlns (node &rest body)
224 "Install a local alias table from NODE and execute BODY."
225 (declare (debug (form &rest form)) (indent 1))
226 (let ((xmlns (make-symbol "xmlns")))
227 `(let ((,xmlns (soap-extract-xmlns ,node *soap-local-xmlns*)))
228 (let ((*soap-default-xmlns* (or (nth 0 ,xmlns) *soap-default-xmlns*))
229 (*soap-target-xmlns* (or (nth 1 ,xmlns) *soap-target-xmlns*))
230 (*soap-local-xmlns* (nth 2 ,xmlns)))
231 ,@body))))
232
233(defun soap-get-target-namespace (node)
234 "Return the target namespace of NODE.
235This is the namespace in which new elements will be defined."
236 (or (xml-get-attribute-or-nil node 'targetNamespace)
237 (cdr (assoc "tns" *soap-local-xmlns*))
238 *soap-target-xmlns*))
239
240(defun soap-xml-get-children1 (node child-name)
241 "Return the children of NODE named CHILD-NAME.
242This is the same as `xml-get-children', but CHILD-NAME can have
243namespace tag."
244 (let (result)
245 (dolist (c (xml-node-children node))
246 (when (and (consp c)
247 (soap-with-local-xmlns c
248 ;; We use `ignore-errors' here because we want to silently
249 ;; skip nodes for which we cannot convert them to a
250 ;; well-known name.
251 (eq (ignore-errors (soap-l2wk (xml-node-name c))) child-name)))
252 (push c result)))
253 (nreverse result)))
254
255(defun soap-xml-get-attribute-or-nil1 (node attribute)
256 "Return the NODE's ATTRIBUTE, or nil if it does not exist.
257This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can
258be tagged with a namespace tag."
259 (catch 'found
260 (soap-with-local-xmlns node
261 (dolist (a (xml-node-attributes node))
262 ;; We use `ignore-errors' here because we want to silently skip
263 ;; attributes for which we cannot convert them to a well-known name.
264 (when (eq (ignore-errors (soap-l2wk (car a))) attribute)
265 (throw 'found (cdr a)))))))
266
267
268;;;; XML namespaces
269
270;; An element in an XML namespace, "things" stored in soap-xml-namespaces will
271;; be derived from this object.
272
273(defstruct soap-element
274 name
275 ;; The "well-known" namespace tag for the element. For example, while
276 ;; parsing XML documents, we can have different tags for the XMLSchema
277 ;; namespace, but internally all our XMLSchema elements will have the "xsd"
278 ;; tag.
279 namespace-tag)
280
281(defun soap-element-fq-name (element)
282 "Return a fully qualified name for ELEMENT.
283A fq name is the concatenation of the namespace tag and the
284element name."
285 (concat (soap-element-namespace-tag element)
286 ":" (soap-element-name element)))
287
288;; a namespace link stores an alias for an object in once namespace to a
289;; "target" object possibly in a different namespace
290
291(defstruct (soap-namespace-link (:include soap-element))
292 target)
293
294;; A namespace is a collection of soap-element objects under a name (the name
295;; of the namespace).
296
297(defstruct soap-namespace
298 (name nil :read-only t) ; e.g "http://xml.apache.org/xml-soap"
299 (elements (make-hash-table :test 'equal) :read-only t))
300
301(defun soap-namespace-put (element ns)
302 "Store ELEMENT in NS.
303Multiple elements with the same name can be stored in a
304namespace. When retrieving the element you can specify a
305discriminant predicate to `soap-namespace-get'"
306 (let ((name (soap-element-name element)))
307 (push element (gethash name (soap-namespace-elements ns)))))
308
309(defun soap-namespace-put-link (name target ns &optional replace)
310 "Store a link from NAME to TARGET in NS.
311An error will be signaled if an element by the same name is
312already present in NS, unless REPLACE is non nil.
313
314TARGET can be either a SOAP-ELEMENT or a string denoting an
315element name into another namespace.
316
317If NAME is nil, an element with the same name as TARGET will be
318added to the namespace."
319
320 (unless (and name (not (equal name "")))
321 ;; if name is nil, use TARGET as a name...
322 (cond ((soap-element-p target)
323 (setq name (soap-element-name target)))
324 ((stringp target)
325 (cond ((string-match "^\\(.*\\):\\(.*\\)$" target)
326 (setq name (match-string 2 target)))
327 (t
328 (setq name target))))))
329
330 (assert name) ; by now, name should be valid
331 (push (make-soap-namespace-link :name name :target target)
332 (gethash name (soap-namespace-elements ns))))
333
334(defun soap-namespace-get (name ns &optional discriminant-predicate)
335 "Retrieve an element with NAME from the namespace NS.
336If multiple elements with the same name exist,
337DISCRIMINANT-PREDICATE is used to pick one of them. This allows
338storing elements of different types (like a message type and a
339binding) but the same name."
340 (assert (stringp name))
341 (let ((elements (gethash name (soap-namespace-elements ns))))
342 (cond (discriminant-predicate
343 (catch 'found
344 (dolist (e elements)
345 (when (funcall discriminant-predicate e)
346 (throw 'found e)))))
347 ((= (length elements) 1) (car elements))
348 ((> (length elements) 1)
349 (error "Soap-namespace-get(%s): multiple elements, discriminant needed" name))
350 (t
351 nil))))
352
353
354;;;; WSDL documents
355;;;;; WSDL document elements
356
357(defstruct (soap-basic-type (:include soap-element))
358 kind ; a symbol of: string, dateTime, long, int
359 )
360
361(defstruct soap-sequence-element
362 name type nillable? multiple?)
363
364(defstruct (soap-sequence-type (:include soap-element))
365 parent ; OPTIONAL WSDL-TYPE name
366 elements ; LIST of SOAP-SEQUCENCE-ELEMENT
367 )
368
369(defstruct (soap-array-type (:include soap-element))
370 element-type ; WSDL-TYPE of the array elements
371 )
372
373(defstruct (soap-message (:include soap-element))
374 parts ; ALIST of NAME => WSDL-TYPE name
375 )
376
377(defstruct (soap-operation (:include soap-element))
378 parameter-order
379 input ; (NAME . MESSAGE)
380 output ; (NAME . MESSAGE)
381 faults) ; a list of (NAME . MESSAGE)
382
383(defstruct (soap-port-type (:include soap-element))
384 operations) ; a namespace of operations
385
386;; A bound operation is an operation which has a soap action and a use
387;; method attached -- these are attached as part of a binding and we
388;; can have different bindings for the same operations.
389(defstruct soap-bound-operation
390 operation ; SOAP-OPERATION
391 soap-action ; value for SOAPAction HTTP header
392 use ; 'literal or 'encoded, see http://www.w3.org/TR/wsdl#_soap:body
393 )
394
395(defstruct (soap-binding (:include soap-element))
396 port-type
397 (operations (make-hash-table :test 'equal) :readonly t))
398
399(defstruct (soap-port (:include soap-element))
400 service-url
401 binding)
402
403(defun soap-default-xsd-types ()
404 "Return a namespace containing some of the XMLSchema types."
405 (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema")))
406 (dolist (type '("string" "dateTime" "boolean" "long" "int" "float"
407 "base64Binary" "anyType" "Array" "byte[]"))
408 (soap-namespace-put
409 (make-soap-basic-type :name type :kind (intern type))
410 ns))
411 ns))
412
413(defun soap-default-soapenc-types ()
414 "Return a namespace containing some of the SOAPEnc types."
415 (let ((ns (make-soap-namespace :name "http://schemas.xmlsoap.org/soap/encoding/")))
416 (dolist (type '("string" "dateTime" "boolean" "long" "int" "float"
417 "base64Binary" "anyType" "Array" "byte[]"))
418 (soap-namespace-put
419 (make-soap-basic-type :name type :kind (intern type))
420 ns))
421 ns))
422
423(defun soap-type-p (element)
424 "Return t if ELEMENT is a SOAP data type (basic or complex)."
425 (or (soap-basic-type-p element)
426 (soap-sequence-type-p element)
427 (soap-array-type-p element)))
428
429
430;;;;; The WSDL document
431
432;; The WSDL data structure used for encoding/decoding SOAP messages
433(defstruct soap-wsdl
434 origin ; file or URL from which this wsdl was loaded
435 ports ; a list of SOAP-PORT instances
436 alias-table ; a list of namespace aliases
437 namespaces ; a list of namespaces
438 )
439
440(defun soap-wsdl-add-alias (alias name wsdl)
441 "Add a namespace ALIAS for NAME to the WSDL document."
442 (push (cons alias name) (soap-wsdl-alias-table wsdl)))
443
444(defun soap-wsdl-find-namespace (name wsdl)
445 "Find a namespace by NAME in the WSDL document."
446 (catch 'found
447 (dolist (ns (soap-wsdl-namespaces wsdl))
448 (when (equal name (soap-namespace-name ns))
449 (throw 'found ns)))))
450
451(defun soap-wsdl-add-namespace (ns wsdl)
452 "Add the namespace NS to the WSDL document.
453If a namespace by this name already exists in WSDL, individual
454elements will be added to it."
455 (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl)))
456 (if existing
457 ;; Add elements from NS to EXISTING, replacing existing values.
458 (maphash (lambda (key value)
459 (dolist (v value)
460 (soap-namespace-put v existing)))
461 (soap-namespace-elements ns))
462 (push ns (soap-wsdl-namespaces wsdl)))))
463
464(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table)
465 "Retrieve element NAME from the WSDL document.
466
467PREDICATE is used to differentiate between elements when NAME
468refers to multiple elements. A typical value for this would be a
469structure predicate for the type of element you want to retrieve.
470For example, to retrieve a message named \"foo\" when other
471elements named \"foo\" exist in the WSDL you could use:
472
473 (soap-wsdl-get \"foo\" WSDL 'soap-message-p)
474
475If USE-LOCAL-ALIAS-TABLE is not nil, `*soap-local-xmlns*` will be
476used to resolve the namespace alias."
477 (let ((alias-table (soap-wsdl-alias-table wsdl))
478 namespace element-name element)
479
480 (when (symbolp name)
481 (setq name (symbol-name name)))
482
483 (when use-local-alias-table
484 (setq alias-table (append *soap-local-xmlns* alias-table)))
485
486 (cond ((consp name) ; a fully qualified name, as returned by `soap-l2fq'
487 (setq element-name (cdr name))
488 (when (symbolp element-name)
489 (setq element-name (symbol-name element-name)))
490 (setq namespace (soap-wsdl-find-namespace (car name) wsdl))
491 (unless namespace
492 (error "Soap-wsdl-get(%s): unknown namespace: %s" name namespace)))
493
494 ((string-match "^\\(.*\\):\\(.*\\)$" name)
495 (setq element-name (match-string 2 name))
496
497 (let* ((ns-alias (match-string 1 name))
498 (ns-name (cdr (assoc ns-alias alias-table))))
499 (unless ns-name
500 (error "Soap-wsdl-get(%s): cannot find namespace alias %s" name ns-alias))
501
502 (setq namespace (soap-wsdl-find-namespace ns-name wsdl))
503 (unless namespace
504 (error "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias %s"
505 name ns-name ns-alias))))
506 (t
507 (error "Soap-wsdl-get(%s): bad name" name)))
508
509 (setq element (soap-namespace-get
510 element-name namespace
511 (if predicate
512 (lambda (e)
513 (or (funcall 'soap-namespace-link-p e)
514 (funcall predicate e)))
515 nil)))
516
517 (unless element
518 (error "Soap-wsdl-get(%s): cannot find element" name))
519
520 (if (soap-namespace-link-p element)
521 ;; NOTE: don't use the local alias table here
522 (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate)
523 element)))
524
525;;;;; Resolving references for wsdl types
526
527;; See `soap-wsdl-resolve-references', which is the main entry point for
528;; resolving references
529
530(defun soap-resolve-references-for-element (element wsdl)
531 "Resolve references in ELEMENT using the WSDL document.
532This is a generic function which invokes a specific function
533depending on the element type.
534
535If ELEMENT has no resolver function, it is silently ignored.
536
537All references are resolved in-place, that is the ELEMENT is
538updated."
539 (let ((resolver (get (aref element 0) 'soap-resolve-references)))
540 (when resolver
541 (funcall resolver element wsdl))))
542
543(defun soap-resolve-references-for-sequence-type (type wsdl)
544 "Resolve references for a sequence TYPE using WSDL document.
545See also `soap-resolve-references-for-element' and
546`soap-wsdl-resolve-references'"
547 (let ((parent (soap-sequence-type-parent type)))
548 (when (or (consp parent) (stringp parent))
549 (setf (soap-sequence-type-parent type)
550 (soap-wsdl-get parent wsdl 'soap-type-p))))
551 (dolist (element (soap-sequence-type-elements type))
552 (let ((element-type (soap-sequence-element-type element)))
553 (cond ((or (consp element-type) (stringp element-type))
554 (setf (soap-sequence-element-type element)
555 (soap-wsdl-get element-type wsdl 'soap-type-p)))
556 ((soap-element-p element-type)
557 ;; since the element already has a child element, it
558 ;; could be an inline structure. we must resolve
559 ;; references in it, because it might not be reached by
560 ;; scanning the wsdl names.
561 (soap-resolve-references-for-element element-type wsdl))))))
562
563(defun soap-resolve-references-for-array-type (type wsdl)
564 "Resolve references for an array TYPE using WSDL.
565See also `soap-resolve-references-for-element' and
566`soap-wsdl-resolve-references'"
567 (let ((element-type (soap-array-type-element-type type)))
568 (when (or (consp element-type) (stringp element-type))
569 (setf (soap-array-type-element-type type)
570 (soap-wsdl-get element-type wsdl 'soap-type-p)))))
571
572(defun soap-resolve-references-for-message (message wsdl)
573 "Resolve references for a MESSAGE type using the WSDL document.
574See also `soap-resolve-references-for-element' and
575`soap-wsdl-resolve-references'"
576 (let (resolved-parts)
577 (dolist (part (soap-message-parts message))
578 (let ((name (car part))
579 (type (cdr part)))
580 (when (stringp name)
581 (setq name (intern name)))
582 (when (or (consp type) (stringp type))
583 (setq type (soap-wsdl-get type wsdl 'soap-type-p)))
584 (push (cons name type) resolved-parts)))
585 (setf (soap-message-parts message) (nreverse resolved-parts))))
586
587(defun soap-resolve-references-for-operation (operation wsdl)
588 "Resolve references for an OPERATION type using the WSDL document.
589See also `soap-resolve-references-for-element' and
590`soap-wsdl-resolve-references'"
591 (let ((input (soap-operation-input operation))
592 (counter 0))
593 (let ((name (car input))
594 (message (cdr input)))
595 ;; Name this part if it was not named
596 (when (or (null name) (equal name ""))
597 (setq name (format "in%d" (incf counter))))
598 (when (or (consp message) (stringp message))
599 (setf (soap-operation-input operation)
600 (cons (intern name) (soap-wsdl-get message wsdl 'soap-message-p))))))
601
602 (let ((output (soap-operation-output operation))
603 (counter 0))
604 (let ((name (car output))
605 (message (cdr output)))
606 (when (or (null name) (equal name ""))
607 (setq name (format "out%d" (incf counter))))
608 (when (or (consp message) (stringp message))
609 (setf (soap-operation-output operation)
610 (cons (intern name) (soap-wsdl-get message wsdl 'soap-message-p))))))
611
612 (let ((resolved-faults nil)
613 (counter 0))
614 (dolist (fault (soap-operation-faults operation))
615 (let ((name (car fault))
616 (message (cdr fault)))
617 (when (or (null name) (equal name ""))
618 (setq name (format "fault%d" (incf counter))))
619 (if (or (consp message) (stringp message))
620 (push (cons (intern name) (soap-wsdl-get message wsdl 'soap-message-p))
621 resolved-faults)
622 (push fault resolved-faults))))
623 (setf (soap-operation-faults operation) resolved-faults))
624
625 (when (= (length (soap-operation-parameter-order operation)) 0)
626 (setf (soap-operation-parameter-order operation)
627 (mapcar 'car (soap-message-parts
628 (cdr (soap-operation-input operation))))))
629
630 (setf (soap-operation-parameter-order operation)
631 (mapcar (lambda (p)
632 (if (stringp p)
633 (intern p)
634 p))
635 (soap-operation-parameter-order operation))))
636
637(defun soap-resolve-references-for-binding (binding wsdl)
638 "Resolve references for a BINDING type using the WSDL document.
639See also `soap-resolve-references-for-element' and
640`soap-wsdl-resolve-references'"
641 (when (or (consp (soap-binding-port-type binding))
642 (stringp (soap-binding-port-type binding)))
643 (setf (soap-binding-port-type binding)
644 (soap-wsdl-get (soap-binding-port-type binding) wsdl 'soap-port-type-p)))
645
646 (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding))))
647 (maphash (lambda (k v)
648 (setf (soap-bound-operation-operation v)
649 (soap-namespace-get k port-ops 'soap-operation-p)))
650 (soap-binding-operations binding))))
651
652(defun soap-resolve-references-for-port (port wsdl)
653 "Resolve references for a PORT type using the WSDL document.
654See also `soap-resolve-references-for-element' and
655`soap-wsdl-resolve-references'"
656 (when (or (consp (soap-port-binding port))
657 (stringp (soap-port-binding port)))
658 (setf (soap-port-binding port)
659 (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p))))
660
661;; Install resolvers for our types
662(progn
663 (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references
664 'soap-resolve-references-for-sequence-type)
665 (put (aref (make-soap-array-type) 0) 'soap-resolve-references
666 'soap-resolve-references-for-array-type)
667 (put (aref (make-soap-message) 0) 'soap-resolve-references
668 'soap-resolve-references-for-message)
669 (put (aref (make-soap-operation) 0) 'soap-resolve-references
670 'soap-resolve-references-for-operation)
671 (put (aref (make-soap-binding) 0) 'soap-resolve-references
672 'soap-resolve-references-for-binding)
673 (put (aref (make-soap-port) 0) 'soap-resolve-references
674 'soap-resolve-references-for-port))
675
676(defun soap-wsdl-resolve-references (wsdl)
677 "Resolve all references inside the WSDL structure.
678
679When the WSDL elements are created from the XML document, they
680refer to each other by name. For example, the ELEMENT-TYPE slot
681of an SOAP-ARRAY-TYPE will contain the name of the element and
682the user would have to call `soap-wsdl-get' to obtain the actual
683element.
684
685After the entire document is loaded, we resolve all these
686references to the actual elements they refer to so that at
687runtime, we don't have to call `soap-wsdl-get' each time we
688traverse an element tree."
689 (let ((nprocessed 0)
690 (nstag-id 0)
691 (alias-table (soap-wsdl-alias-table wsdl)))
692 (dolist (ns (soap-wsdl-namespaces wsdl))
693 (let ((nstag (car-safe (rassoc (soap-namespace-name ns) alias-table))))
694 (unless nstag
695 ;; If this namespace does not have an alias, create one for it.
696 (catch 'done
697 (while t
698 (setq nstag (format "ns%d" (incf nstag-id)))
699 (unless (assoc nstag alias-table)
700 (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl)
701 (throw 'done t)))))
702
703 (maphash (lambda (name element)
704 (cond ((soap-element-p element) ; skip links
705 (incf nprocessed)
706 (soap-resolve-references-for-element element wsdl)
707 (setf (soap-element-namespace-tag element) nstag))
708 ((listp element)
709 (dolist (e element)
710 (when (soap-element-p e)
711 (incf nprocessed)
712 (soap-resolve-references-for-element e wsdl)
713 (setf (soap-element-namespace-tag e) nstag))))))
714 (soap-namespace-elements ns))))
715
716 (message "Processed %d" nprocessed))
717 wsdl)
718
719;;;;; Loading WSDL from XML documents
720
721(defun soap-load-wsdl-from-url (url)
722 "Load a WSDL document from URL and return it.
723The returned WSDL document needs to be used for `soap-invoke'
724calls."
725 (let ((url-request-method "GET")
726 (url-package-name "soap-client.el")
727 (url-package-version "1.0")
728 (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
729 (url-request-coding-system 'utf-8)
730 (url-http-attempt-keepalives nil))
731 (let ((buffer (url-retrieve-synchronously url)))
732 (with-current-buffer buffer
733 (declare (special url-http-response-status))
734 (if (> url-http-response-status 299)
735 (error "Error retrieving WSDL: %s" url-http-response-status))
736 (let ((mime-part (mm-dissect-buffer t t)))
737 (unless mime-part
738 (error "Failed to decode response from server"))
739 (unless (equal (car (mm-handle-type mime-part)) "text/xml")
740 (error "Server response is not an XML document"))
741 (with-temp-buffer
742 (mm-insert-part mime-part)
743 (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max)))))
744 (prog1
745 (let ((wsdl (soap-parse-wsdl wsdl-xml)))
746 (setf (soap-wsdl-origin wsdl) url)
747 wsdl)
748 (kill-buffer buffer)))))))))
749
750(defun soap-load-wsdl (file)
751 "Load a WSDL document from FILE and return it."
752 (with-temp-buffer
753 (insert-file-contents file)
754 (let ((xml (car (xml-parse-region (point-min) (point-max)))))
755 (let ((wsdl (soap-parse-wsdl xml)))
756 (setf (soap-wsdl-origin wsdl) file)
757 wsdl))))
758
759(defun soap-parse-wsdl (node)
760 "Construct a WSDL structure from NODE, which is an XML document."
761 (soap-with-local-xmlns node
762
763 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions)
764 nil
765 "soap-parse-wsdl: expecting wsdl:definitions node, got %s"
766 (soap-l2wk (xml-node-name node)))
767
768 (let ((wsdl (make-soap-wsdl)))
769
770 ;; Add the local alias table to the wsdl document -- it will be used for
771 ;; all types in this document even after we finish parsing it.
772 (setf (soap-wsdl-alias-table wsdl) *soap-local-xmlns*)
773
774 ;; Add the XSD types to the wsdl document
775 (let ((ns (soap-default-xsd-types)))
776 (soap-wsdl-add-namespace ns wsdl)
777 (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
778
779 ;; Add the soapenc types to the wsdl document
780 (let ((ns (soap-default-soapenc-types)))
781 (soap-wsdl-add-namespace ns wsdl)
782 (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
783
784 ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes
785 ;; and build our type-library
786
787 (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
788 (dolist (node (xml-node-children types))
789 ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema))
790 ;; because each node can install its own alias type so the schema
791 ;; nodes might have a different prefix.
792 (when (consp node)
793 (soap-with-local-xmlns node
794 (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
795 (soap-wsdl-add-namespace (soap-parse-schema node) wsdl))))))
796
797 (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
798 (dolist (node (soap-xml-get-children1 node 'wsdl:message))
799 (soap-namespace-put (soap-parse-message node) ns))
800
801 (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
802 (let ((port-type (soap-parse-port-type node)))
803 (soap-namespace-put port-type ns)
804 (soap-wsdl-add-namespace (soap-port-type-operations port-type) wsdl)))
805
806 (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
807 (soap-namespace-put (soap-parse-binding node) ns))
808
809 (dolist (node (soap-xml-get-children1 node 'wsdl:service))
810 (dolist (node (soap-xml-get-children1 node 'wsdl:port))
811 (let ((name (xml-get-attribute node 'name))
812 (binding (xml-get-attribute node 'binding))
813 (url (let ((n (car (soap-xml-get-children1 node 'wsdlsoap:address))))
814 (xml-get-attribute n 'location))))
815 (let ((port (make-soap-port
816 :name name :binding (soap-l2fq binding 'tns) :service-url url)))
817 (soap-namespace-put port ns)
818 (push port (soap-wsdl-ports wsdl))))))
819
820 (soap-wsdl-add-namespace ns wsdl))
821
822 (soap-wsdl-resolve-references wsdl)
823
824 wsdl)))
825
826(defun soap-parse-schema (node)
827 "Parse a schema NODE.
828Return a SOAP-NAMESPACE containing the elements."
829 (soap-with-local-xmlns node
830 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
831 nil
832 "soap-parse-schema: expecting an xsd:schema node, got %s"
833 (soap-l2wk (xml-node-name node)))
834 (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
835 ;; NOTE: we only extract the complexTypes from the schema, we wouldn't
836 ;; know how to handle basic types beyond the built in ones anyway.
837 (dolist (node (soap-xml-get-children1 node 'xsd:complexType))
838 (soap-namespace-put (soap-parse-complex-type node) ns))
839
840 (dolist (node (soap-xml-get-children1 node 'xsd:element))
841 (soap-namespace-put (soap-parse-schema-element node) ns))
842
843 ns)))
844
845(defun soap-parse-schema-element (node)
846 "Parse NODE and construct a schema element from it."
847 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element)
848 nil
849 "soap-parse-schema-element: expecting xsd:element node, got %s"
850 (soap-l2wk (xml-node-name node)))
851 (let ((name (xml-get-attribute-or-nil node 'name))
852 type)
853 ;; A schema element that contains an inline complex type --
854 ;; construct the actual complex type for it.
855 (let ((type-node (soap-xml-get-children1 node 'xsd:complexType)))
856 (when (> (length type-node) 0)
857 (assert (= (length type-node) 1)) ; only one complex type definition per element
858 (setq type (soap-parse-complex-type (car type-node)))))
859 (setf (soap-element-name type) name)
860 type))
861
862(defun soap-parse-complex-type (node)
863 "Parse NODE and construct a complex type from it."
864 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType)
865 nil
866 "soap-parse-complex-type: expecting xsd:complexType node, got %s"
867 (soap-l2wk (xml-node-name node)))
868 (let ((name (xml-get-attribute-or-nil node 'name))
869 ;; Use a dummy type for the complex type, it will be replaced
870 ;; with the real type below, except when the complex type node
871 ;; is empty...
872 (type (make-soap-sequence-type :elements nil)))
873 (dolist (c (xml-node-children node))
874 (when (consp c) ; skip string nodes, which are whitespace
875 (let ((node-name (soap-l2wk (xml-node-name c))))
876 (cond
877 ((eq node-name 'xsd:sequence)
878 (setq type (soap-parse-complex-type-sequence c)))
879 ((eq node-name 'xsd:complexContent)
880 (setq type (soap-parse-complex-type-complex-content c)))
881 ((eq node-name 'xsd:attribute)
882 ;; The name of this node comes from an attribute tag
883 (let ((n (xml-get-attribute-or-nil c 'name)))
884 (setq name n)))
885 (t
886 (error "Unknown node type %s" node-name))))))
887 (setf (soap-element-name type) name)
888 type))
889
890(defun soap-parse-sequence (node)
891 "Parse NODE and a list of sequence elements that it defines.
892NODE is assumed to be an xsd:sequence node. In that case, each
893of its children is assumed to be a sequence element. Each
894sequence element is parsed constructing the corresponding type.
895A list of these types is returned."
896 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:sequence)
897 nil
898 "soap-parse-sequence: expecting xsd:sequence node, got %s"
899 (soap-l2wk (xml-node-name node)))
900 (let (elements)
901 (dolist (e (soap-xml-get-children1 node 'xsd:element))
902 (let ((name (xml-get-attribute-or-nil e 'name))
903 (type (xml-get-attribute-or-nil e 'type))
904 (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable) "true")
905 (let ((e (xml-get-attribute-or-nil e 'minOccurs)))
906 (and e (equal e "0")))))
907 (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs)))
908 (and e (not (equal e "1"))))))
909 (if type
910 (setq type (soap-l2fq type 'tns))
911
912 ;; The node does not have a type, maybe it has a complexType
913 ;; defined inline...
914 (let ((type-node (soap-xml-get-children1 e 'xsd:complexType)))
915 (when (> (length type-node) 0)
916 (assert (= (length type-node) 1)
917 nil
918 "only one complex type definition per element supported")
919 (setq type (soap-parse-complex-type (car type-node))))))
920
921 (push (make-soap-sequence-element
922 :name (intern name) :type type :nillable? nillable? :multiple? multiple?)
923 elements)))
924 (nreverse elements)))
925
926(defun soap-parse-complex-type-sequence (node)
927 "Parse NODE as a sequence type."
928 (let ((elements (soap-parse-sequence node)))
929 (make-soap-sequence-type :elements elements)))
930
931(defun soap-parse-complex-type-complex-content (node)
932 "Parse NODE as a xsd:complexContent node.
933A sequence or an array type is returned depending on the actual
934contents."
935 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent)
936 nil
937 "soap-parse-complex-type-complex-content: expecting xsd:complexContent node, got %s"
938 (soap-l2wk (xml-node-name node)))
939 (let (array? parent elements)
940 (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension)))
941 (restriction (car-safe (soap-xml-get-children1 node 'xsd:restriction))))
942 ;; a complex content node is either an extension or a restriction
943 (cond (extension
944 (setq parent (xml-get-attribute-or-nil extension 'base))
945 (setq elements (soap-parse-sequence
946 (car (soap-xml-get-children1 extension 'xsd:sequence)))))
947 (restriction
948 (let ((base (xml-get-attribute-or-nil restriction 'base)))
949 (assert (equal base "soapenc:Array")
950 nil
951 "restrictions supported only for soapenc:Array types, this is a %s"
952 base))
953 (setq array? t)
954 (let ((attribute (car (soap-xml-get-children1 restriction 'xsd:attribute))))
955 (let ((array-type (soap-xml-get-attribute-or-nil1 attribute 'wsdl:arrayType)))
956 (when (string-match "^\\(.*\\)\\[\\]$" array-type)
957 (setq parent (match-string 1 array-type))))))
958
959 (t
960 (error "Unknown complex type"))))
961
962 (if parent
963 (setq parent (soap-l2fq parent 'tns)))
964
965 (if array?
966 (make-soap-array-type :element-type parent)
967 (make-soap-sequence-type :parent parent :elements elements))))
968
969(defun soap-parse-message (node)
970 "Parse NODE as a wsdl:message and return the corresponding type."
971 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message)
972 nil
973 "soap-parse-message: expecting wsdl:message node, got %s"
974 (soap-l2wk (xml-node-name node)))
975 (let ((name (xml-get-attribute-or-nil node 'name))
976 parts)
977 (dolist (p (soap-xml-get-children1 node 'wsdl:part))
978 (let ((name (xml-get-attribute-or-nil p 'name))
979 (type (xml-get-attribute-or-nil p 'type))
980 (element (xml-get-attribute-or-nil p 'element)))
981
982 (when type
983 (setq type (soap-l2fq type 'tns)))
984
985 (when element
986 (setq element (soap-l2fq element 'tns)))
987
988 (push (cons name (or type element)) parts)))
989 (make-soap-message :name name :parts (nreverse parts))))
990
991(defun soap-parse-port-type (node)
992 "Parse NODE as a wsdl:portType and return the corresponding port."
993 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType)
994 nil
995 "soap-parse-port-type: expecting wsdl:portType node got %s"
996 (soap-l2wk (xml-node-name node)))
997 (let ((ns (make-soap-namespace
998 :name (concat "urn:" (xml-get-attribute node 'name)))))
999 (dolist (node (soap-xml-get-children1 node 'wsdl:operation))
1000 (let ((o (soap-parse-operation node)))
1001
1002 (let ((other-operation (soap-namespace-get (soap-element-name o) ns 'soap-operation-p)))
1003 (if other-operation
1004 ;; Unfortunately, the Confluence WSDL defines two operations
1005 ;; named "search" which differ only in parameter names...
1006 (soap-warning "Discarding duplicate operation: %s" (soap-element-name o))
1007
1008 (progn
1009 (soap-namespace-put o ns)
1010
1011 ;; link all messages from this namespace, as this namespace
1012 ;; will be used for decoding the response.
1013 (destructuring-bind (name . message) (soap-operation-input o)
1014 (soap-namespace-put-link name message ns))
1015
1016 (destructuring-bind (name . message) (soap-operation-output o)
1017 (soap-namespace-put-link name message ns))
1018
1019 (dolist (fault (soap-operation-faults o))
1020 (destructuring-bind (name . message) fault
1021 (soap-namespace-put-link name message ns 'replace)))
1022
1023 )))))
1024
1025 (make-soap-port-type :name (xml-get-attribute node 'name)
1026 :operations ns)))
1027
1028(defun soap-parse-operation (node)
1029 "Parse NODE as a wsdl:operation and return the corresponding type."
1030 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation)
1031 nil
1032 "soap-parse-operation: expecting wsdl:operation node, got %s"
1033 (soap-l2wk (xml-node-name node)))
1034 (let ((name (xml-get-attribute node 'name))
1035 (parameter-order (split-string (xml-get-attribute node 'parameterOrder)))
1036 input output faults)
1037 (dolist (n (xml-node-children node))
1038 (when (consp n) ; skip string nodes which are whitespace
1039 (let ((node-name (soap-l2wk (xml-node-name n))))
1040 (cond
1041 ((eq node-name 'wsdl:input)
1042 (let ((message (xml-get-attribute n 'message))
1043 (name (xml-get-attribute n 'name)))
1044 (setq input (cons name (soap-l2fq message 'tns)))))
1045 ((eq node-name 'wsdl:output)
1046 (let ((message (xml-get-attribute n 'message))
1047 (name (xml-get-attribute n 'name)))
1048 (setq output (cons name (soap-l2fq message 'tns)))))
1049 ((eq node-name 'wsdl:fault)
1050 (let ((message (xml-get-attribute n 'message))
1051 (name (xml-get-attribute n 'name)))
1052 (push (cons name (soap-l2fq message 'tns)) faults)))))))
1053 (make-soap-operation
1054 :name name
1055 :parameter-order parameter-order
1056 :input input
1057 :output output
1058 :faults (nreverse faults))))
1059
1060(defun soap-parse-binding (node)
1061 "Parse NODE as a wsdl:binding and return the corresponding type."
1062 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding)
1063 nil
1064 "soap-parse-binding: expecting wsdl:binding node, got %s"
1065 (soap-l2wk (xml-node-name node)))
1066 (let ((name (xml-get-attribute node 'name))
1067 (type (xml-get-attribute node 'type)))
1068 (let ((binding (make-soap-binding :name name :port-type (soap-l2fq type 'tns))))
1069 (dolist (wo (soap-xml-get-children1 node 'wsdl:operation))
1070 (let ((name (xml-get-attribute wo 'name))
1071 soap-action
1072 use)
1073 (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation))
1074 (setq soap-action (xml-get-attribute-or-nil so 'soapAction)))
1075
1076 ;; Search a wsdlsoap:body node and find a "use" tag. The
1077 ;; same use tag is assumed to be present for both input and
1078 ;; output types (although the WDSL spec allows separate
1079 ;; "use"-s for each of them...
1080
1081 (dolist (i (soap-xml-get-children1 wo 'wsdl:input))
1082 (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body))
1083 (setq use (or use
1084 (xml-get-attribute-or-nil b 'use)))))
1085
1086 (unless use
1087 (dolist (i (soap-xml-get-children1 wo 'wsdl:output))
1088 (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body))
1089 (setq use (or use
1090 (xml-get-attribute-or-nil b 'use))))))
1091
1092 (puthash name (make-soap-bound-operation :operation name
1093 :soap-action soap-action
1094 :use (and use (intern use)))
1095 (soap-binding-operations binding))))
1096 binding)))
1097
1098;;;; SOAP type decoding
1099
1100(defvar *soap-multi-refs* nil
1101 "The list of multi-ref nodes in the current SOAP response.
1102This is a dynamically bound variable used during decoding the
1103SOAP response.")
1104
1105(defvar *soap-decoded-multi-refs* nil
1106 "List of decoded multi-ref nodes in the current SOAP response.
1107This is a dynamically bound variable used during decoding the
1108SOAP response.")
1109
1110(defvar *soap-current-wsdl* nil
1111 "The current WSDL document used when decoding the SOAP response.
1112This is a dynamically bound variable.")
1113
1114(defun soap-decode-type (type node)
1115 "Use TYPE (an xsd type) to decode the contents of NODE.
1116
1117NODE is an XML node, representing some SOAP encoded value or a
1118reference to another XML node (a multiRef). This function will
1119resolve the multiRef reference, if any, than call a TYPE specific
1120decode function to perform the actual decoding."
1121 (let ((href (xml-get-attribute-or-nil node 'href)))
1122 (cond (href
1123 (catch 'done
1124 ;; NODE is actually a HREF, find the target and decode that.
1125 ;; Check first if we already decoded this multiref.
1126
1127 (let ((decoded (cdr (assoc href *soap-decoded-multi-refs*))))
1128 (when decoded
1129 (throw 'done decoded)))
1130
1131 (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched
1132
1133 (let ((id (match-string 1 href)))
1134 (dolist (mr *soap-multi-refs*)
1135 (let ((mrid (xml-get-attribute mr 'id)))
1136 (when (equal id mrid)
1137 ;; recurse here, in case there are multiple HREF's
1138 (let ((decoded (soap-decode-type type mr)))
1139 (push (cons href decoded) *soap-decoded-multi-refs*)
1140 (throw 'done decoded)))))
1141 (error "Cannot find href %s" href))))
1142 (t
1143 (soap-with-local-xmlns node
1144 (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true")
1145 nil
1146 (let ((decoder (get (aref type 0) 'soap-decoder)))
1147 (assert decoder nil "no soap-decoder for %s type" (aref type 0))
1148 (funcall decoder type node))))))))
1149
1150(defun soap-decode-any-type (node)
1151 "Decode NODE using type information inside it."
1152 ;; If the NODE has type information, we use that...
1153 (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type)))
1154 (if type
1155 (let ((wtype (soap-wsdl-get type *soap-current-wsdl* 'soap-type-p)))
1156 (if wtype
1157 (soap-decode-type wtype node)
1158 ;; The node has type info encoded in it, but we don't know how
1159 ;; to decode it...
1160 (error "Soap-decode-any-type: node has unknown type: %s" type)))
1161
1162 ;; No type info in the node...
1163
1164 (let ((contents (xml-node-children node)))
1165 (if (and (= (length contents) 1) (stringp (car contents)))
1166 ;; contents is just a string
1167 (car contents)
1168
1169 ;; we assume the NODE is a sequence with every element a
1170 ;; structure name
1171 (let (result)
1172 (dolist (element contents)
1173 (let ((key (xml-node-name element))
1174 (value (soap-decode-any-type element)))
1175 (push (cons key value) result)))
1176 (nreverse result)))))))
1177
1178(defun soap-decode-array (node)
1179 "Decode NODE as an Array using type information inside it."
1180 (let ((type (soap-xml-get-attribute-or-nil1 node 'soapenc:arrayType))
1181 (wtype nil)
1182 (contents (xml-node-children node))
1183 result)
1184 (when type
1185 ;; Type is in the format "someType[NUM]" where NUM is the number of
1186 ;; elements in the array. We discard the [NUM] part.
1187 (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type))
1188 (setq wtype (soap-wsdl-get type *soap-current-wsdl* 'soap-type-p))
1189 (unless wtype
1190 ;; The node has type info encoded in it, but we don't know how to
1191 ;; decode it...
1192 (error "Soap-decode-array: node has unknown type: %s" type)))
1193 (dolist (e contents)
1194 (when (consp e)
1195 (push (if wtype
1196 (soap-decode-type wtype e)
1197 (soap-decode-any-type e))
1198 result)))
1199 (nreverse result)))
1200
1201(defun soap-decode-basic-type (type node)
1202 "Use TYPE to decode the contents of NODE.
1203TYPE is a `soap-basic-type' struct, and NODE is an XML document.
1204A LISP value is returned based on the contents of NODE and the
1205type-info stored in TYPE."
1206 (let ((contents (xml-node-children node))
1207 (type-kind (soap-basic-type-kind type)))
1208
1209 (if (null contents)
1210 nil
1211 (ecase type-kind
1212 (string (car contents))
1213 (dateTime (car contents)) ; TODO: convert to a date time
1214 ((long int float) (string-to-number (car contents)))
1215 (boolean (string= (downcase (car contents)) "true"))
1216 (base64Binary (base64-decode-string (car contents)))
1217 (anyType (soap-decode-any-type node))
1218 (Array (soap-decode-array node))))))
1219
1220(defun soap-decode-sequence-type (type node)
1221 "Use TYPE to decode the contents of NODE.
1222TYPE is assumed to be a sequence type and an ALIST with the
1223contents of the NODE is returned."
1224 (let ((result nil)
1225 (parent (soap-sequence-type-parent type)))
1226 (when parent
1227 (setq result (nreverse (soap-decode-type parent node))))
1228 (dolist (element (soap-sequence-type-elements type))
1229 (let ((instance-count 0)
1230 (e-name (soap-sequence-element-name element))
1231 (e-type (soap-sequence-element-type element)))
1232 (dolist (node (xml-get-children node e-name))
1233 (incf instance-count)
1234 (push (cons e-name (soap-decode-type e-type node)) result))
1235 ;; Do some sanity checking
1236 (cond ((and (= instance-count 0)
1237 (not (soap-sequence-element-nillable? element)))
1238 (soap-warning "While decoding %s: missing non-nillable slot %s"
1239 (soap-element-name type) e-name))
1240 ((and (> instance-count 1)
1241 (not (soap-sequence-element-multiple? element)))
1242 (soap-warning "While decoding %s: multiple slots named %s"
1243 (soap-element-name type) e-name)))))
1244 (nreverse result)))
1245
1246(defun soap-decode-array-type (type node)
1247 "Use TYPE to decode the contents of NODE.
1248TYPE is assumed to be an array type. Arrays are decoded as lists.
1249This is because it is easier to work with list results in LISP."
1250 (let ((result nil)
1251 (element-type (soap-array-type-element-type type)))
1252 (dolist (node (xml-node-children node))
1253 (when (consp node)
1254 (push (soap-decode-type element-type node) result)))
1255 (nreverse result)))
1256
1257(progn
1258 (put (aref (make-soap-basic-type) 0)
1259 'soap-decoder 'soap-decode-basic-type)
1260 (put (aref (make-soap-sequence-type) 0)
1261 'soap-decoder 'soap-decode-sequence-type)
1262 (put (aref (make-soap-array-type) 0)
1263 'soap-decoder 'soap-decode-array-type))
1264
1265;;;; Soap Envelope parsing
1266
1267(put 'soap-error
1268 'error-conditions
1269 '(error soap-error))
1270(put 'soap-error 'error-message "SOAP error")
1271
1272(defun soap-parse-envelope (node operation wsdl)
1273 "Parse the SOAP envelope in NODE and return the response.
1274OPERATION is the WSDL operation for which we expect the response,
1275WSDL is used to decode the NODE"
1276 (soap-with-local-xmlns node
1277 (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope)
1278 nil
1279 "soap-parse-envelope: expecting soap:Envelope node, got %s"
1280 (soap-l2wk (xml-node-name node)))
1281 (let ((body (car (soap-xml-get-children1 node 'soap:Body))))
1282
1283 (let ((fault (car (soap-xml-get-children1 body 'soap:Fault))))
1284 (when fault
1285 (let ((fault-code (let ((n (car (xml-get-children fault 'faultcode))))
1286 (car-safe (xml-node-children n))))
1287 (fault-string (let ((n (car (xml-get-children fault 'faultstring))))
1288 (car-safe (xml-node-children n)))))
1289 (while t
1290 (signal 'soap-error (list fault-code fault-string))))))
1291
1292 ;; First (non string) element of the body is the root node of he
1293 ;; response
1294 (let ((response (if (eq (soap-bound-operation-use operation) 'literal)
1295 ;; For 'literal uses, the response is the actual body
1296 body
1297 ;; ...otherwise the first non string element
1298 ;; of the body is the response
1299 (catch 'found
1300 (dolist (n (xml-node-children body))
1301 (when (consp n)
1302 (throw 'found n)))))))
1303 (soap-parse-response response operation wsdl body)))))
1304
1305(defun soap-parse-response (response-node operation wsdl soap-body)
1306 "Parse RESPONSE-NODE and return the result as a LISP value.
1307OPERATION is the WSDL operation for which we expect the response,
1308WSDL is used to decode the NODE.
1309
1310SOAP-BODY is the body of the SOAP envelope (of which
1311RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE
1312reference multiRef parts which are external to RESPONSE-NODE."
1313 (let* ((*soap-current-wsdl* wsdl)
1314 (op (soap-bound-operation-operation operation))
1315 (use (soap-bound-operation-use operation))
1316 (message (cdr (soap-operation-output op))))
1317
1318 (soap-with-local-xmlns response-node
1319
1320 (when (eq use 'encoded)
1321 (let* ((received-message-name (soap-l2fq (xml-node-name response-node)))
1322 (received-message (soap-wsdl-get received-message-name wsdl 'soap-message-p)))
1323 (unless (eq received-message message)
1324 (error "Unexpected message: got %s, expecting %s"
1325 received-message-name
1326 (soap-element-name message)))))
1327
1328 (let ((decoded-parts nil)
1329 (*soap-multi-refs* (xml-get-children soap-body 'multiRef))
1330 (*soap-decoded-multi-refs* nil))
1331
1332 (dolist (part (soap-message-parts message))
1333 (let ((tag (car part))
1334 (type (cdr part))
1335 node)
1336
1337 (setq node
1338 (cond
1339 ((eq use 'encoded)
1340 (car (xml-get-children response-node tag)))
1341
1342 ((eq use 'literal)
1343 (catch 'found
1344 (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
1345 (ns-name (cdr (assoc (soap-element-namespace-tag type) ns-aliases)))
1346 (fqname (cons ns-name (soap-element-name type))))
1347 (dolist (c (xml-node-children response-node))
1348 (when (consp c)
1349 (soap-with-local-xmlns c
1350 (when (equal (soap-l2fq (xml-node-name c)) fqname)
1351 (throw 'found c))))))))))
1352
1353 (unless node
1354 (error "Soap-parse-response(%s): cannot find message part %s"
1355 (soap-element-name op) tag))
1356 (push (soap-decode-type type node) decoded-parts)))
1357
1358 decoded-parts))))
1359
1360;;;; SOAP type encoding
1361
1362(defvar *soap-encoded-namespaces* nil
1363 "A list of namespace tags used during encoding a message.
1364This list is populated by `soap-encode-value' and used by
1365`soap-create-envelope' to add aliases for these namespace to the
1366XML request.
1367
1368This variable is dynamically bound in `soap-create-envelope'.")
1369
1370(defun soap-encode-value (xml-tag value type)
1371 "Encode inside an XML-TAG the VALUE using TYPE.
1372The resulting XML data is inserted in the current buffer
1373at (point)/
1374
1375TYPE is one of the soap-*-type structures which defines how VALUE
1376is to be encoded. This is a generic function which finds an
1377encoder function based on TYPE and calls that encoder to do the
1378work."
1379 (let ((encoder (get (aref type 0) 'soap-encoder)))
1380 (assert encoder nil "no soap-encoder for %s type" (aref type 0))
1381 ;; XML-TAG can be a string or a symbol, but we pass only string's to the
1382 ;; encoders
1383 (when (symbolp xml-tag)
1384 (setq xml-tag (symbol-name xml-tag)))
1385 (funcall encoder xml-tag value type))
1386 (add-to-list '*soap-encoded-namespaces* (soap-element-namespace-tag type)))
1387
1388(defun soap-encode-basic-type (xml-tag value type)
1389 "Encode inside XML-TAG the LISP VALUE according to TYPE.
1390Do not call this function directly, use `soap-encode-value'
1391instead."
1392 (let ((xsi-type (soap-element-fq-name type))
1393 (basic-type (soap-basic-type-kind type)))
1394
1395 ;; try to classify the type based on the value type and use that type when
1396 ;; encoding
1397 (when (eq basic-type 'anyType)
1398 (cond ((stringp value)
1399 (setq xsi-type "xsd:string" basic-type 'string))
1400 ((integerp value)
1401 (setq xsi-type "xsd:int" basic-type 'int))
1402 ((memq value '(t nil))
1403 (setq xsi-type "xsd:boolean" basic-type 'boolean))
1404 (t
1405 (error "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value"
1406 xml-tag value xsi-type))))
1407
1408 (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
1409
1410 ;; We have some ambiguity here, as a nil value represents "false" when the
1411 ;; type is boolean, we will never have a "nil" boolean type...
1412
1413 (if (or value (eq basic-type 'boolean))
1414 (progn
1415 (insert ">")
1416 (case basic-type
1417 (string
1418 (unless (stringp value)
1419 (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
1420 xml-tag value xsi-type))
1421 (insert (url-insert-entities-in-string value)))
1422
1423 (dateTime
1424 (cond ((and (consp value) ; is there a time-value-p ?
1425 (>= (length value) 2)
1426 (numberp (nth 0 value))
1427 (numberp (nth 1 value)))
1428 ;; Value is a (current-time) style value, convert to a string
1429 (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value)))
1430 ((stringp value)
1431 (insert (url-insert-entities-in-string value)))
1432 (t
1433 (error "Soap-encode-basic-type(%s, %s, %s): not a dateTime value"
1434 xml-tag value xsi-type))))
1435
1436 (boolean
1437 (unless (memq value '(t nil))
1438 (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value"
1439 xml-tag value xsi-type))
1440 (insert (if value "true" "false")))
1441
1442 ((long int)
1443 (unless (integerp value)
1444 (error "Soap-encode-basic-type(%s, %s, %s): not an integer value"
1445 xml-tag value xsi-type))
1446 (insert (number-to-string value)))
1447
1448 (base64Binary
1449 (unless (stringp value)
1450 (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
1451 xml-tag value xsi-type))
1452 (insert (base64-encode-string value)))
1453
1454 (otherwise
1455 (error "Soap-encode-basic-type(%s, %s, %s): don't know how to encode"
1456 xml-tag value xsi-type))))
1457
1458 (insert " xsi:nil=\"true\">"))
1459 (insert "</" xml-tag ">\n")))
1460
1461(defun soap-encode-sequence-type (xml-tag value type)
1462 "Encode inside XML-TAG the LISP VALUE according to TYPE.
1463Do not call this function directly, use `soap-encode-value'
1464instead."
1465 (let ((xsi-type (soap-element-fq-name type)))
1466 (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
1467 (if value
1468 (progn
1469 (insert ">\n")
1470 (let ((parents (list type))
1471 (parent (soap-sequence-type-parent type)))
1472
1473 (while parent
1474 (push parent parents)
1475 (setq parent (soap-sequence-type-parent parent)))
1476
1477 (dolist (type parents)
1478 (dolist (element (soap-sequence-type-elements type))
1479 (let ((instance-count 0)
1480 (e-name (soap-sequence-element-name element))
1481 (e-type (soap-sequence-element-type element)))
1482 (dolist (v value)
1483 (when (equal (car v) e-name)
1484 (incf instance-count)
1485 (soap-encode-value e-name (cdr v) e-type)))
1486
1487 ;; Do some sanity checking
1488 (cond ((and (= instance-count 0)
1489 (not (soap-sequence-element-nillable? element)))
1490 (soap-warning "While encoding %s: missing non-nillable slot %s"
1491 (soap-element-name type) e-name))
1492 ((and (> instance-count 1)
1493 (not (soap-sequence-element-multiple? element)))
1494 (soap-warning "While encoding %s: multiple slots named %s"
1495 (soap-element-name type) e-name))))))))
1496 (insert " xsi:nil=\"true\">"))
1497 (insert "</" xml-tag ">\n")))
1498
1499(defun soap-encode-array-type (xml-tag value type)
1500 "Encode inside XML-TAG the LISP VALUE according to TYPE.
1501Do not call this function directly, use `soap-encode-value'
1502instead."
1503 (unless (vectorp value)
1504 (error "Soap-encode: %s(%s) expects a vector, got: %s"
1505 xml-tag (soap-element-fq-name type) value))
1506 (let* ((element-type (soap-array-type-element-type type))
1507 (array-type (concat (soap-element-fq-name element-type)
1508 "[" (format "%s" (length value)) "]")))
1509 (insert "<" xml-tag
1510 " soapenc:arrayType=\"" array-type "\" "
1511 " xsi:type=\"soapenc:Array\">\n")
1512 (loop for i below (length value)
1513 do (soap-encode-value xml-tag (aref value i) element-type))
1514 (insert "</" xml-tag ">\n")))
1515
1516(progn
1517 (put (aref (make-soap-basic-type) 0)
1518 'soap-encoder 'soap-encode-basic-type)
1519 (put (aref (make-soap-sequence-type) 0)
1520 'soap-encoder 'soap-encode-sequence-type)
1521 (put (aref (make-soap-array-type) 0)
1522 'soap-encoder 'soap-encode-array-type))
1523
1524(defun soap-encode-body (operation parameters wsdl)
1525 "Create the body of a SOAP request for OPERATION in the current buffer.
1526PARAMETERS is a list of parameters supplied to the OPERATION.
1527
1528The OPERATION and PARAMETERS are encoded according to the WSDL
1529document."
1530 (let* ((op (soap-bound-operation-operation operation))
1531 (use (soap-bound-operation-use operation))
1532 (message (cdr (soap-operation-input op)))
1533 (parameter-order (soap-operation-parameter-order op)))
1534
1535 (unless (= (length parameter-order) (length parameters))
1536 (error "Wrong number of parameters for %s: expected %d, got %s"
1537 (soap-element-name op)
1538 (length parameter-order)
1539 (length parameters)))
1540
1541 (insert "<soap:Body>\n")
1542 (when (eq use 'encoded)
1543 (add-to-list '*soap-encoded-namespaces* (soap-element-namespace-tag op))
1544 (insert "<" (soap-element-fq-name op) ">\n"))
1545
1546 (let ((param-table (loop for formal in parameter-order
1547 for value in parameters
1548 collect (cons formal value))))
1549 (dolist (part (soap-message-parts message))
1550 (let* ((param-name (car part))
1551 (type (cdr part))
1552 (tag-name (if (eq use 'encoded)
1553 param-name
1554 (soap-element-name type)))
1555 (value (cdr (assoc param-name param-table)))
1556 (start-pos (point)))
1557 (soap-encode-value tag-name value type)
1558 (when (eq use 'literal)
1559 ;; hack: add the xmlns attribute to the tag, the only way
1560 ;; ASP.NET web services recognize the namespace of the
1561 ;; element itself...
1562 (save-excursion
1563 (goto-char start-pos)
1564 (when (re-search-forward " ")
1565 (let* ((ns (soap-element-namespace-tag type))
1566 (namespace (cdr (assoc ns (soap-wsdl-alias-table wsdl)))))
1567 (when namespace
1568 (insert "xmlns=\"" namespace "\" ")))))))))
1569
1570 (when (eq use 'encoded)
1571 (insert "</" (soap-element-fq-name op) ">\n"))
1572 (insert "</soap:Body>\n")))
1573
1574(defun soap-create-envelope (operation parameters wsdl)
1575 "Create a SOAP request envelope for OPERATION using PARAMETERS.
1576WSDL is the wsdl document used to encode the PARAMETERS."
1577 (with-temp-buffer
1578 (let ((*soap-encoded-namespaces* '("xsi" "soap" "soapenc"))
1579 (use (soap-bound-operation-use operation)))
1580
1581 ;; Create the request body
1582 (soap-encode-body operation parameters wsdl)
1583
1584 ;; Put the envelope around the body
1585 (goto-char (point-min))
1586 (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n")
1587 (when (eq use 'encoded)
1588 (insert " soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n"))
1589 (dolist (nstag *soap-encoded-namespaces*)
1590 (insert " xmlns:" nstag "=\"")
1591 (let ((nsname (cdr (assoc nstag *soap-well-known-xmlns*))))
1592 (unless nsname
1593 (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl)))))
1594 (insert nsname)
1595 (insert "\"\n")))
1596 (insert ">\n")
1597 (goto-char (point-max))
1598 (insert "</soap:Envelope>\n"))
1599
1600 (buffer-string)))
1601
1602;;;; invoking soap methods
1603
1604(defcustom soap-debug nil
1605 "When t, enable some debugging facilities."
1606 :type 'boolean
1607 :group 'soap-client)
1608
1609(defun soap-invoke (wsdl service operation-name &rest parameters)
1610 "Invoke a SOAP operation and return the result.
1611
1612WSDL is used for encoding the request and decoding the response.
1613It also contains information about the WEB server address that
1614will service the request.
1615
1616SERVICE is the SOAP service to invoke.
1617
1618OPERATION-NAME is the operation to invoke.
1619
1620PARAMETERS -- the remaining parameters are used as parameters for
1621the SOAP request.
1622
1623NOTE: The SOAP service provider should document the available
1624operations and their parameters for the service. You can also
1625use the `soap-inspect' function to browse the available
1626operations in a WSDL document."
1627 (let ((port (catch 'found
1628 (dolist (p (soap-wsdl-ports wsdl))
1629 (when (equal service (soap-element-name p))
1630 (throw 'found p))))))
1631 (unless port
1632 (error "Unknown SOAP service: %s" service))
1633
1634 (let* ((binding (soap-port-binding port))
1635 (operation (gethash operation-name (soap-binding-operations binding))))
1636 (unless operation
1637 (error "No operation %s for SOAP service %s" operation-name service))
1638
1639 (let ((url-request-method "POST")
1640 (url-package-name "soap-client.el")
1641 (url-package-version "1.0")
1642 (url-http-version "1.0")
1643 (url-request-data (soap-create-envelope operation parameters wsdl))
1644 (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
1645 (url-request-coding-system 'utf-8)
1646 (url-http-attempt-keepalives t)
1647 (url-request-extra-headers (list
1648 (cons "SOAPAction" (soap-bound-operation-soap-action operation))
1649 (cons "Content-Type" "text/xml; charset=utf-8"))))
1650 (let ((buffer (url-retrieve-synchronously (soap-port-service-url port))))
1651 (condition-case err
1652 (with-current-buffer buffer
1653 (declare (special url-http-response-status))
1654 (if (null url-http-response-status)
1655 (error "No HTTP response from server"))
1656 (if (and soap-debug (> url-http-response-status 299))
1657 ;; This is a warning because some SOAP errors come
1658 ;; back with a HTTP response 500 (internal server
1659 ;; error)
1660 (warn "Error in SOAP response: HTTP code %s" url-http-response-status))
1661 (when (> (buffer-size) 1000000)
1662 (soap-warning "Received large message: %s bytes" (buffer-size)))
1663 (let ((mime-part (mm-dissect-buffer t t)))
1664 (unless mime-part
1665 (error "Failed to decode response from server"))
1666 (unless (equal (car (mm-handle-type mime-part)) "text/xml")
1667 (error "Server response is not an XML document"))
1668 (with-temp-buffer
1669 (mm-insert-part mime-part)
1670 (let ((response (car (xml-parse-region (point-min) (point-max)))))
1671 (prog1
1672 (soap-parse-envelope response operation wsdl)
1673 (kill-buffer buffer)
1674 (mm-destroy-part mime-part))))))
1675 (soap-error
1676 ;; Propagate soap-errors -- they are error replies of the
1677 ;; SOAP protocol and don't indicate a communication
1678 ;; problem or a bug in this code.
1679 (signal (car err) (cdr err)))
1680 (error
1681 (when soap-debug
1682 (pop-to-buffer buffer))
1683 (error (error-message-string err)))))))))
1684
1685(provide 'soap-client)
1686
1687
1688;;; Local Variables:
1689;;; mode: emacs-lisp
1690;;; mode: outline-minor
1691;;; outline-regexp: ";;;;+"
1692;;; End:
1693
1694;;; soap-client.el ends here
diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el
new file mode 100644
index 00000000000..4ea6bef0d8c
--- /dev/null
+++ b/lisp/net/soap-inspect.el
@@ -0,0 +1,352 @@
1;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures
2
3;; Copyright (C) 2010-2011 Alex Harsanyi <AlexHarsanyi@gmail.com>
4
5;; This program is free software: you can redistribute it and/or modify
6;; it under the terms of the GNU General Public License as published by
7;; the Free Software Foundation, either version 3 of the License, or
8;; (at your option) any later version.
9
10;; This program is distributed in the hope that it will be useful,
11;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13;; GNU General Public License for more details.
14
15;; You should have received a copy of the GNU General Public License
16;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17
18;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com)
19;; Created: October 2010
20;; Keywords: soap, web-services
21;; Homepage: http://code.google.com/p/emacs-soap-client
22;;
23
24;;; Commentary:
25;;
26;; This package provides an inspector for a WSDL document loaded with
27;; `soap-load-wsdl' or `soap-load-wsdl-from-url'. To use it, evaluate:
28;;
29;; (soap-inspect *wsdl*)
30;;
31;; This will pop-up the inspector buffer. You can click on ports, operations
32;; and types to explore the structure of the wsdl document.
33;;
34
35(require 'soap-client)
36
37
38;;; Code:
39
40;;; sample-value
41
42(defun soap-sample-value (type)
43 "Provide a sample value for TYPE, a WSDL type.
44A sample value is a LISP value which soap-client.el will accept
45for encoding it using TYPE when making SOAP requests.
46
47This is a generic function, depending on TYPE a specific function
48will be called."
49 (let ((sample-value (get (aref type 0) 'soap-sample-value)))
50 (if sample-value
51 (funcall sample-value type)
52 (error "Cannot provide sample value for type %s" (aref type 0)))))
53
54(defun soap-sample-value-for-basic-type (type)
55 "Provide a sample value for TYPE which is a basic type.
56This is a specific function which should not be called directly,
57use `soap-sample-value' instead."
58 (case (soap-basic-type-kind type)
59 (string "a string value")
60 (boolean t) ; could be nil as well
61 ((long int) (random 4200))
62 ;; TODO: we need better sample values for more types.
63 (t (format "%s" (soap-basic-type-kind type)))))
64
65(defun soap-sample-value-for-seqence-type (type)
66 "Provide a sample value for TYPE which is a sequence type.
67Values for sequence types are ALISTS of (slot-name . VALUE) for
68each sequence element.
69
70This is a specific function which should not be called directly,
71use `soap-sample-value' instead."
72 (let ((sample-value nil))
73 (dolist (element (soap-sequence-type-elements type))
74 (push (cons (soap-sequence-element-name element)
75 (soap-sample-value (soap-sequence-element-type element)))
76 sample-value))
77 (when (soap-sequence-type-parent type)
78 (setq sample-value
79 (append (soap-sample-value (soap-sequence-type-parent type))
80 sample-value)))
81 sample-value))
82
83(defun soap-sample-value-for-array-type (type)
84 "Provide a sample value for TYPE which is an array type.
85Values for array types are LISP vectors of values which are
86array's element type.
87
88This is a specific function which should not be called directly,
89use `soap-sample-value' instead."
90 (let* ((element-type (soap-array-type-element-type type))
91 (sample1 (soap-sample-value element-type))
92 (sample2 (soap-sample-value element-type)))
93 ;; Our sample value is a vector of two elements, but any number of
94 ;; elements are permissible
95 (vector sample1 sample2 '&etc)))
96
97(defun soap-sample-value-for-message (message)
98 "Provide a sample value for a WSDL MESSAGE.
99This is a specific function which should not be called directly,
100use `soap-sample-value' instead."
101 ;; NOTE: parameter order is not considered.
102 (let (sample-value)
103 (dolist (part (soap-message-parts message))
104 (push (cons (car part)
105 (soap-sample-value (cdr part)))
106 sample-value))
107 (nreverse sample-value)))
108
109(progn
110 ;; Install soap-sample-value methods for our types
111 (put (aref (make-soap-basic-type) 0) 'soap-sample-value
112 'soap-sample-value-for-basic-type)
113
114 (put (aref (make-soap-sequence-type) 0) 'soap-sample-value
115 'soap-sample-value-for-seqence-type)
116
117 (put (aref (make-soap-array-type) 0) 'soap-sample-value
118 'soap-sample-value-for-array-type)
119
120 (put (aref (make-soap-message) 0) 'soap-sample-value
121 'soap-sample-value-for-message) )
122
123
124
125;;; soap-inspect
126
127(defvar soap-inspect-previous-items nil
128 "A stack of previously inspected items in the *soap-inspect* buffer.
129Used to implement the BACK button.")
130
131(defvar soap-inspect-current-item nil
132 "The current item being inspected in the *soap-inspect* buffer.")
133
134(progn
135 (make-variable-buffer-local 'soap-inspect-previous-items)
136 (make-variable-buffer-local 'soap-inspect-current-item))
137
138(defun soap-inspect (element)
139 "Inspect a SOAP ELEMENT in the *soap-inspect* buffer.
140The buffer is populated with information about ELEMENT with links
141to its sub elements. If ELEMENT is the WSDL document itself, the
142entire WSDL can be inspected."
143 (let ((inspect (get (aref element 0) 'soap-inspect)))
144 (unless inspect
145 (error "Soap-inspect: no inspector for element"))
146
147 (with-current-buffer (get-buffer-create "*soap-inspect*")
148 (setq buffer-read-only t)
149 (let ((inhibit-read-only t))
150 (erase-buffer)
151
152 (when soap-inspect-current-item
153 (push soap-inspect-current-item
154 soap-inspect-previous-items))
155 (setq soap-inspect-current-item element)
156
157 (funcall inspect element)
158
159 (unless (null soap-inspect-previous-items)
160 (insert "\n\n")
161 (insert-text-button
162 "[back]"
163 'type 'soap-client-describe-back-link
164 'item element)
165 (insert "\n"))
166 (goto-char (point-min))
167 (pop-to-buffer (current-buffer))))))
168
169
170(define-button-type 'soap-client-describe-link
171 'face 'italic
172 'help-echo "mouse-2, RET: describe item"
173 'follow-link t
174 'action (lambda (button)
175 (let ((item (button-get button 'item)))
176 (soap-inspect item)))
177 'skip t)
178
179(define-button-type 'soap-client-describe-back-link
180 'face 'italic
181 'help-echo "mouse-2, RET: browse the previous item"
182 'follow-link t
183 'action (lambda (button)
184 (let ((item (pop soap-inspect-previous-items)))
185 (when item
186 (setq soap-inspect-current-item nil)
187 (soap-inspect item))))
188 'skip t)
189
190(defun soap-insert-describe-button (element)
191 "Insert a button to inspect ELEMENT when pressed."
192 (insert-text-button
193 (soap-element-fq-name element)
194 'type 'soap-client-describe-link
195 'item element))
196
197(defun soap-inspect-basic-type (basic-type)
198 "Insert information about BASIC-TYPE into the current buffer."
199 (insert "Basic type: " (soap-element-fq-name basic-type))
200 (insert "\nSample value\n")
201 (pp (soap-sample-value basic-type) (current-buffer)))
202
203(defun soap-inspect-sequence-type (sequence)
204 "Insert information about SEQUENCE into the current buffer."
205 (insert "Sequence type: " (soap-element-fq-name sequence) "\n")
206 (when (soap-sequence-type-parent sequence)
207 (insert "Parent: ")
208 (soap-insert-describe-button
209 (soap-sequence-type-parent sequence))
210 (insert "\n"))
211 (insert "Elements: \n")
212 (dolist (element (soap-sequence-type-elements sequence))
213 (insert "\t" (symbol-name (soap-sequence-element-name element))
214 "\t")
215 (soap-insert-describe-button
216 (soap-sequence-element-type element))
217 (when (soap-sequence-element-multiple? element)
218 (insert " multiple"))
219 (when (soap-sequence-element-nillable? element)
220 (insert " optional"))
221 (insert "\n"))
222 (insert "Sample value:\n")
223 (pp (soap-sample-value sequence) (current-buffer)))
224
225(defun soap-inspect-array-type (array)
226 "Insert information about the ARRAY into the current buffer."
227 (insert "Array name: " (soap-element-fq-name array) "\n")
228 (insert "Element type: ")
229 (soap-insert-describe-button
230 (soap-array-type-element-type array))
231 (insert "\nSample value:\n")
232 (pp (soap-sample-value array) (current-buffer)))
233
234(defun soap-inspect-message (message)
235 "Insert information about MESSAGE into the current buffer."
236 (insert "Message name: " (soap-element-fq-name message) "\n")
237 (insert "Parts:\n")
238 (dolist (part (soap-message-parts message))
239 (insert "\t" (symbol-name (car part))
240 " type: ")
241 (soap-insert-describe-button (cdr part))
242 (insert "\n")))
243
244(defun soap-inspect-operation (operation)
245 "Insert information about OPERATION into the current buffer."
246 (insert "Operation name: " (soap-element-fq-name operation) "\n")
247 (let ((input (soap-operation-input operation)))
248 (insert "\tInput: " (symbol-name (car input)) " (" )
249 (soap-insert-describe-button (cdr input))
250 (insert ")\n"))
251 (let ((output (soap-operation-output operation)))
252 (insert "\tOutput: " (symbol-name (car output)) " (")
253 (soap-insert-describe-button (cdr output))
254 (insert ")\n"))
255
256 (insert "\n\nSample invocation:\n")
257 (let ((sample-message-value (soap-sample-value (cdr (soap-operation-input operation))))
258 (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation))))
259 (let ((sample-invocation (append funcall (mapcar 'cdr sample-message-value))))
260 (pp sample-invocation (current-buffer)))))
261
262(defun soap-inspect-port-type (port-type)
263 "Insert information about PORT-TYPE into the current buffer."
264 (insert "Port-type name: " (soap-element-fq-name port-type) "\n")
265 (insert "Operations:\n")
266 (loop for o being the hash-values of
267 (soap-namespace-elements (soap-port-type-operations port-type))
268 do (progn
269 (insert "\t")
270 (soap-insert-describe-button (car o)))))
271
272(defun soap-inspect-binding (binding)
273 "Insert information about BINDING into the current buffer."
274 (insert "Binding: " (soap-element-fq-name binding) "\n")
275 (insert "\n")
276 (insert "Bound operations:\n")
277 (let* ((ophash (soap-binding-operations binding))
278 (operations (loop for o being the hash-keys of ophash
279 collect o))
280 op-name-width)
281
282 (setq operations (sort operations 'string<))
283
284 (setq op-name-width (loop for o in operations maximizing (length o)))
285
286 (dolist (op operations)
287 (let* ((bound-op (gethash op ophash))
288 (soap-action (soap-bound-operation-soap-action bound-op))
289 (use (soap-bound-operation-use bound-op)))
290 (unless soap-action
291 (setq soap-action ""))
292 (insert "\t")
293 (soap-insert-describe-button (soap-bound-operation-operation bound-op))
294 (when (or use (not (equal soap-action "")))
295 (insert (make-string (- op-name-width (length op)) ?\s))
296 (insert " (")
297 (insert soap-action)
298 (when use
299 (insert " " (symbol-name use)))
300 (insert ")"))
301 (insert "\n")))))
302
303(defun soap-inspect-port (port)
304 "Insert information about PORT into the current buffer."
305 (insert "Port name: " (soap-element-name port) "\n"
306 "Service URL: " (soap-port-service-url port) "\n"
307 "Binding: ")
308 (soap-insert-describe-button (soap-port-binding port)))
309
310(defun soap-inspect-wsdl (wsdl)
311 "Insert information about WSDL into the current buffer."
312 (insert "WSDL Origin: " (soap-wsdl-origin wsdl) "\n")
313 (insert "Ports:")
314 (dolist (p (soap-wsdl-ports wsdl))
315 (insert "\n--------------------\n")
316 ;; (soap-insert-describe-button p)
317 (soap-inspect-port p))
318 (insert "\n--------------------\nNamespace alias table:\n")
319 (dolist (a (soap-wsdl-alias-table wsdl))
320 (insert "\t" (car a) " => " (cdr a) "\n")))
321
322(progn
323 ;; Install the soap-inspect methods for our types
324
325 (put (aref (make-soap-basic-type) 0) 'soap-inspect
326 'soap-inspect-basic-type)
327
328 (put (aref (make-soap-sequence-type) 0) 'soap-inspect
329 'soap-inspect-sequence-type)
330
331 (put (aref (make-soap-array-type) 0) 'soap-inspect
332 'soap-inspect-array-type)
333
334 (put (aref (make-soap-message) 0) 'soap-inspect
335 'soap-inspect-message)
336 (put (aref (make-soap-operation) 0) 'soap-inspect
337 'soap-inspect-operation)
338
339 (put (aref (make-soap-port-type) 0) 'soap-inspect
340 'soap-inspect-port-type)
341
342 (put (aref (make-soap-binding) 0) 'soap-inspect
343 'soap-inspect-binding)
344
345 (put (aref (make-soap-port) 0) 'soap-inspect
346 'soap-inspect-port)
347
348 (put (aref (make-soap-wsdl) 0) 'soap-inspect
349 'soap-inspect-wsdl))
350
351(provide 'soap-inspect)
352;;; soap-inspect.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-15 00:12:14 +0000