diff options
| author | Michael Albinus <michael.albinus@gmx.de> | 2011-02-16 10:25:37 +0100 |
|---|---|---|
| committer | Michael Albinus <michael.albinus@gmx.de> | 2011-02-16 10:25:37 +0100 |
| commit | 16d2ff891446b821ef348d451f73683a0d3a21f6 (patch) | |
| tree | d35b6d2ade22d67ad3c04121a222d8db92966efd | |
| parent | c6cefd36106ddade8fc65fc074221132357428ff (diff) | |
| download | emacs-16d2ff891446b821ef348d451f73683a0d3a21f6.tar.gz | |
* net/soap-client.el:
* net/soap-inspect.el: New files.
| -rw-r--r-- | lisp/ChangeLog | 5 | ||||
| -rw-r--r-- | lisp/net/soap-client.el | 1694 | ||||
| -rw-r--r-- | lisp/net/soap-inspect.el | 352 |
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 @@ +2011-02-16 Alex Harsanyi <AlexHarsanyi@gmail.com> + + * net/soap-client.el: + * net/soap-inspect.el: New files. + 2011-02-16 Leo <sdl.web@gmail.com> * 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 @@ +;;;; soap.el -- Access SOAP web services from Emacs + +;; Copyright (C) 2009-2011 Alex Harsanyi <AlexHarsanyi@gmail.com> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com) +;; Created: December, 2009 +;; Keywords: soap, web-services +;; Homepage: http://code.google.com/p/emacs-soap-client +;; + +;;; Commentary: +;; +;; To use the SOAP client, you first need to load the WSDL document for the +;; service you want to access, using `soap-load-wsdl-from-url'. A WSDL +;; document describes the available operations of the SOAP service, how their +;; parameters and responses are encoded. To invoke operations, you use the +;; `soap-invoke' method passing it the WSDL, the service name, the operation +;; you wish to invoke and any required parameters. +;; +;; Idealy, the service you want to access will have some documentation about +;; the operations it supports. If it does not, you can try using +;; `soap-inspect' to browse the WSDL document and see the available operations +;; and their parameters. +;; + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'xml) +(require 'warnings) +(require 'url) +(require 'url-http) +(require 'url-util) +(require 'mm-decode) + +(defsubst soap-warning (message &rest args) + "Display a warning MESSAGE with ARGS, using the 'soap-client warning type." + (display-warning 'soap-client (apply 'format message args) :warning)) + +(defgroup soap-client nil + "Access SOAP web services from Emacs." + :group 'tools) + +;;;; Support for parsing XML documents with namespaces + +;; XML documents with namespaces are difficult to parse because the names of +;; the nodes depend on what "xmlns" aliases have been defined in the document. +;; To work with such documents, we introduce a translation layer between a +;; "well known" namespace tag and the local namespace tag in the document +;; being parsed. + +(defconst *soap-well-known-xmlns* + '(("apachesoap" . "http://xml.apache.org/xml-soap") + ("soapenc" . "http://schemas.xmlsoap.org/soap/encoding/") + ("wsdl" . "http://schemas.xmlsoap.org/wsdl/") + ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/") + ("xsd" . "http://www.w3.org/2001/XMLSchema") + ("xsi" . "http://www.w3.org/2001/XMLSchema-instance") + ("soap" . "http://schemas.xmlsoap.org/soap/envelope/") + ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/") + ("http" . "http://schemas.xmlsoap.org/wsdl/http/") + ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/")) + "A list of well known xml namespaces and their aliases.") + +(defvar *soap-local-xmlns* nil + "A list of local namespace aliases. +This is a dynamically bound variable, controlled by +`soap-with-local-xmlns'.") + +(defvar *soap-default-xmlns* nil + "The default XML namespaces. +Names in this namespace will be unqualified. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defvar *soap-target-xmlns* nil + "The target XML namespace. +New XSD elements will be defined in this namespace, unless they +are fully qualified for a different namespace. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defun soap-wk2l (well-known-name) + "Return local variant of WELL-KNOWN-NAME. +This is done by looking up the namespace in the +`*soap-well-known-xmlns*' table and resolving the namespace to +the local name based on the current local translation table +`*soap-local-xmlns*'. See also `soap-with-local-xmlns'." + (let ((wk-name-1 (if (symbolp well-known-name) + (symbol-name well-known-name) + well-known-name))) + (cond + ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) + (let ((ns (match-string 1 wk-name-1)) + (name (match-string 2 wk-name-1))) + (let ((namespace (cdr (assoc ns *soap-well-known-xmlns*)))) + (cond ((equal namespace *soap-default-xmlns*) + ;; Name is unqualified in the default namespace + (if (symbolp well-known-name) + (intern name) + name)) + (t + (let* ((local-ns (car (rassoc namespace *soap-local-xmlns*))) + (local-name (concat local-ns ":" name))) + (if (symbolp well-known-name) + (intern local-name) + local-name))))))) + (t well-known-name)))) + +(defun soap-l2wk (local-name) + "Convert LOCAL-NAME into a well known name. +The namespace of LOCAL-NAME is looked up in the +`*soap-well-known-xmlns*' table and a well known namespace tag is +used in the name. + +nil is returned if there is no well-known namespace for the +namespace of LOCAL-NAME." + (let ((l-name-1 (if (symbolp local-name) + (symbol-name local-name) + local-name)) + namespace name) + (cond + ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) + (setq name (match-string 2 l-name-1)) + (let ((ns (match-string 1 l-name-1))) + (setq namespace (cdr (assoc ns *soap-local-xmlns*))) + (unless namespace + (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) + (t + (setq name l-name-1) + (setq namespace *soap-default-xmlns*))) + + (if namespace + (let ((well-known-ns (car (rassoc namespace *soap-well-known-xmlns*)))) + (if well-known-ns + (let ((well-known-name (concat well-known-ns ":" name))) + (if (symbol-name local-name) + (intern well-known-name) + well-known-name)) + (progn + ;; (soap-warning "soap-l2wk(%s): namespace %s has no well-known tag" + ;; local-name namespace) + nil))) + ;; if no namespace is defined, just return the unqualified name + name))) + + +(defun soap-l2fq (local-name &optional use-tns) + "Convert LOCAL-NAME into a fully qualified name. +A fully qualified name is a cons of the namespace name and the +name of the element itself. For example \"xsd:string\" is +converted to \(\"http://www.w3.org/2001/XMLSchema\" . \"string\" +\). + +The USE-TNS argument specifies what to do when LOCAL-NAME has no +namespace tag. If USE-TNS is non-nil, the `*soap-target-xmlns*' +will be used as the element's namespace, otherwise +`*soap-default-xmlns*' will be used. + +This is needed because different parts of a WSDL document can use +different namespace aliases for the same element." + (let ((local-name-1 (if (symbolp local-name) + (symbol-name local-name) + local-name))) + (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1) + (let ((ns (match-string 1 local-name-1)) + (name (match-string 2 local-name-1))) + (let ((namespace (cdr (assoc ns *soap-local-xmlns*)))) + (if namespace + (cons namespace name) + (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) + (t + (cons (if use-tns + *soap-target-xmlns* + *soap-default-xmlns*) + local-name))))) + +(defun soap-extract-xmlns (node &optional xmlns-table) + "Return a namespace alias table for NODE by extending XMLNS-TABLE." + (let (xmlns default-ns target-ns) + (dolist (a (xml-node-attributes node)) + (let ((name (symbol-name (car a))) + (value (cdr a))) + (cond ((string= name "targetNamespace") + (setq target-ns value)) + ((string= name "xmlns") + (setq default-ns value)) + ((string-match "^xmlns:\\(.*\\)$" name) + (push (cons (match-string 1 name) value) xmlns))))) + + (let ((tns (assoc "tns" xmlns))) + (cond ((and tns target-ns) + ;; If a tns alias is defined for this node, it must match the target + ;; namespace. + (unless (equal target-ns (cdr tns)) + (soap-warning "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch" + (xml-node-name node)))) + ((and tns (not target-ns)) + (setq target-ns (cdr tns))) + ((and (not tns) target-ns) + ;; a tns alias was not defined in this node. See if the node has + ;; a "targetNamespace" attribute and add an alias to this. Note + ;; that we might override an existing tns alias in XMLNS-TABLE, + ;; but that is intended. + (push (cons "tns" target-ns) xmlns)))) + + (list default-ns target-ns (append xmlns xmlns-table)))) + +(defmacro soap-with-local-xmlns (node &rest body) + "Install a local alias table from NODE and execute BODY." + (declare (debug (form &rest form)) (indent 1)) + (let ((xmlns (make-symbol "xmlns"))) + `(let ((,xmlns (soap-extract-xmlns ,node *soap-local-xmlns*))) + (let ((*soap-default-xmlns* (or (nth 0 ,xmlns) *soap-default-xmlns*)) + (*soap-target-xmlns* (or (nth 1 ,xmlns) *soap-target-xmlns*)) + (*soap-local-xmlns* (nth 2 ,xmlns))) + ,@body)))) + +(defun soap-get-target-namespace (node) + "Return the target namespace of NODE. +This is the namespace in which new elements will be defined." + (or (xml-get-attribute-or-nil node 'targetNamespace) + (cdr (assoc "tns" *soap-local-xmlns*)) + *soap-target-xmlns*)) + +(defun soap-xml-get-children1 (node child-name) + "Return the children of NODE named CHILD-NAME. +This is the same as `xml-get-children', but CHILD-NAME can have +namespace tag." + (let (result) + (dolist (c (xml-node-children node)) + (when (and (consp c) + (soap-with-local-xmlns c + ;; We use `ignore-errors' here because we want to silently + ;; skip nodes for which we cannot convert them to a + ;; well-known name. + (eq (ignore-errors (soap-l2wk (xml-node-name c))) child-name))) + (push c result))) + (nreverse result))) + +(defun soap-xml-get-attribute-or-nil1 (node attribute) + "Return the NODE's ATTRIBUTE, or nil if it does not exist. +This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can +be tagged with a namespace tag." + (catch 'found + (soap-with-local-xmlns node + (dolist (a (xml-node-attributes node)) + ;; We use `ignore-errors' here because we want to silently skip + ;; attributes for which we cannot convert them to a well-known name. + (when (eq (ignore-errors (soap-l2wk (car a))) attribute) + (throw 'found (cdr a))))))) + + +;;;; XML namespaces + +;; An element in an XML namespace, "things" stored in soap-xml-namespaces will +;; be derived from this object. + +(defstruct soap-element + name + ;; The "well-known" namespace tag for the element. For example, while + ;; parsing XML documents, we can have different tags for the XMLSchema + ;; namespace, but internally all our XMLSchema elements will have the "xsd" + ;; tag. + namespace-tag) + +(defun soap-element-fq-name (element) + "Return a fully qualified name for ELEMENT. +A fq name is the concatenation of the namespace tag and the +element name." + (concat (soap-element-namespace-tag element) + ":" (soap-element-name element))) + +;; a namespace link stores an alias for an object in once namespace to a +;; "target" object possibly in a different namespace + +(defstruct (soap-namespace-link (:include soap-element)) + target) + +;; A namespace is a collection of soap-element objects under a name (the name +;; of the namespace). + +(defstruct soap-namespace + (name nil :read-only t) ; e.g "http://xml.apache.org/xml-soap" + (elements (make-hash-table :test 'equal) :read-only t)) + +(defun soap-namespace-put (element ns) + "Store ELEMENT in NS. +Multiple elements with the same name can be stored in a +namespace. When retrieving the element you can specify a +discriminant predicate to `soap-namespace-get'" + (let ((name (soap-element-name element))) + (push element (gethash name (soap-namespace-elements ns))))) + +(defun soap-namespace-put-link (name target ns &optional replace) + "Store a link from NAME to TARGET in NS. +An error will be signaled if an element by the same name is +already present in NS, unless REPLACE is non nil. + +TARGET can be either a SOAP-ELEMENT or a string denoting an +element name into another namespace. + +If NAME is nil, an element with the same name as TARGET will be +added to the namespace." + + (unless (and name (not (equal name ""))) + ;; if name is nil, use TARGET as a name... + (cond ((soap-element-p target) + (setq name (soap-element-name target))) + ((stringp target) + (cond ((string-match "^\\(.*\\):\\(.*\\)$" target) + (setq name (match-string 2 target))) + (t + (setq name target)))))) + + (assert name) ; by now, name should be valid + (push (make-soap-namespace-link :name name :target target) + (gethash name (soap-namespace-elements ns)))) + +(defun soap-namespace-get (name ns &optional discriminant-predicate) + "Retrieve an element with NAME from the namespace NS. +If multiple elements with the same name exist, +DISCRIMINANT-PREDICATE is used to pick one of them. This allows +storing elements of different types (like a message type and a +binding) but the same name." + (assert (stringp name)) + (let ((elements (gethash name (soap-namespace-elements ns)))) + (cond (discriminant-predicate + (catch 'found + (dolist (e elements) + (when (funcall discriminant-predicate e) + (throw 'found e))))) + ((= (length elements) 1) (car elements)) + ((> (length elements) 1) + (error "Soap-namespace-get(%s): multiple elements, discriminant needed" name)) + (t + nil)))) + + +;;;; WSDL documents +;;;;; WSDL document elements + +(defstruct (soap-basic-type (:include soap-element)) + kind ; a symbol of: string, dateTime, long, int + ) + +(defstruct soap-sequence-element + name type nillable? multiple?) + +(defstruct (soap-sequence-type (:include soap-element)) + parent ; OPTIONAL WSDL-TYPE name + elements ; LIST of SOAP-SEQUCENCE-ELEMENT + ) + +(defstruct (soap-array-type (:include soap-element)) + element-type ; WSDL-TYPE of the array elements + ) + +(defstruct (soap-message (:include soap-element)) + parts ; ALIST of NAME => WSDL-TYPE name + ) + +(defstruct (soap-operation (:include soap-element)) + parameter-order + input ; (NAME . MESSAGE) + output ; (NAME . MESSAGE) + faults) ; a list of (NAME . MESSAGE) + +(defstruct (soap-port-type (:include soap-element)) + operations) ; a namespace of operations + +;; A bound operation is an operation which has a soap action and a use +;; method attached -- these are attached as part of a binding and we +;; can have different bindings for the same operations. +(defstruct soap-bound-operation + operation ; SOAP-OPERATION + soap-action ; value for SOAPAction HTTP header + use ; 'literal or 'encoded, see http://www.w3.org/TR/wsdl#_soap:body + ) + +(defstruct (soap-binding (:include soap-element)) + port-type + (operations (make-hash-table :test 'equal) :readonly t)) + +(defstruct (soap-port (:include soap-element)) + service-url + binding) + +(defun soap-default-xsd-types () + "Return a namespace containing some of the XMLSchema types." + (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema"))) + (dolist (type '("string" "dateTime" "boolean" "long" "int" "float" + "base64Binary" "anyType" "Array" "byte[]")) + (soap-namespace-put + (make-soap-basic-type :name type :kind (intern type)) + ns)) + ns)) + +(defun soap-default-soapenc-types () + "Return a namespace containing some of the SOAPEnc types." + (let ((ns (make-soap-namespace :name "http://schemas.xmlsoap.org/soap/encoding/"))) + (dolist (type '("string" "dateTime" "boolean" "long" "int" "float" + "base64Binary" "anyType" "Array" "byte[]")) + (soap-namespace-put + (make-soap-basic-type :name type :kind (intern type)) + ns)) + ns)) + +(defun soap-type-p (element) + "Return t if ELEMENT is a SOAP data type (basic or complex)." + (or (soap-basic-type-p element) + (soap-sequence-type-p element) + (soap-array-type-p element))) + + +;;;;; The WSDL document + +;; The WSDL data structure used for encoding/decoding SOAP messages +(defstruct soap-wsdl + origin ; file or URL from which this wsdl was loaded + ports ; a list of SOAP-PORT instances + alias-table ; a list of namespace aliases + namespaces ; a list of namespaces + ) + +(defun soap-wsdl-add-alias (alias name wsdl) + "Add a namespace ALIAS for NAME to the WSDL document." + (push (cons alias name) (soap-wsdl-alias-table wsdl))) + +(defun soap-wsdl-find-namespace (name wsdl) + "Find a namespace by NAME in the WSDL document." + (catch 'found + (dolist (ns (soap-wsdl-namespaces wsdl)) + (when (equal name (soap-namespace-name ns)) + (throw 'found ns))))) + +(defun soap-wsdl-add-namespace (ns wsdl) + "Add the namespace NS to the WSDL document. +If a namespace by this name already exists in WSDL, individual +elements will be added to it." + (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl))) + (if existing + ;; Add elements from NS to EXISTING, replacing existing values. + (maphash (lambda (key value) + (dolist (v value) + (soap-namespace-put v existing))) + (soap-namespace-elements ns)) + (push ns (soap-wsdl-namespaces wsdl))))) + +(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table) + "Retrieve element NAME from the WSDL document. + +PREDICATE is used to differentiate between elements when NAME +refers to multiple elements. A typical value for this would be a +structure predicate for the type of element you want to retrieve. +For example, to retrieve a message named \"foo\" when other +elements named \"foo\" exist in the WSDL you could use: + + (soap-wsdl-get \"foo\" WSDL 'soap-message-p) + +If USE-LOCAL-ALIAS-TABLE is not nil, `*soap-local-xmlns*` will be +used to resolve the namespace alias." + (let ((alias-table (soap-wsdl-alias-table wsdl)) + namespace element-name element) + + (when (symbolp name) + (setq name (symbol-name name))) + + (when use-local-alias-table + (setq alias-table (append *soap-local-xmlns* alias-table))) + + (cond ((consp name) ; a fully qualified name, as returned by `soap-l2fq' + (setq element-name (cdr name)) + (when (symbolp element-name) + (setq element-name (symbol-name element-name))) + (setq namespace (soap-wsdl-find-namespace (car name) wsdl)) + (unless namespace + (error "Soap-wsdl-get(%s): unknown namespace: %s" name namespace))) + + ((string-match "^\\(.*\\):\\(.*\\)$" name) + (setq element-name (match-string 2 name)) + + (let* ((ns-alias (match-string 1 name)) + (ns-name (cdr (assoc ns-alias alias-table)))) + (unless ns-name + (error "Soap-wsdl-get(%s): cannot find namespace alias %s" name ns-alias)) + + (setq namespace (soap-wsdl-find-namespace ns-name wsdl)) + (unless namespace + (error "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias %s" + name ns-name ns-alias)))) + (t + (error "Soap-wsdl-get(%s): bad name" name))) + + (setq element (soap-namespace-get + element-name namespace + (if predicate + (lambda (e) + (or (funcall 'soap-namespace-link-p e) + (funcall predicate e))) + nil))) + + (unless element + (error "Soap-wsdl-get(%s): cannot find element" name)) + + (if (soap-namespace-link-p element) + ;; NOTE: don't use the local alias table here + (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate) + element))) + +;;;;; Resolving references for wsdl types + +;; See `soap-wsdl-resolve-references', which is the main entry point for +;; resolving references + +(defun soap-resolve-references-for-element (element wsdl) + "Resolve references in ELEMENT using the WSDL document. +This is a generic function which invokes a specific function +depending on the element type. + +If ELEMENT has no resolver function, it is silently ignored. + +All references are resolved in-place, that is the ELEMENT is +updated." + (let ((resolver (get (aref element 0) 'soap-resolve-references))) + (when resolver + (funcall resolver element wsdl)))) + +(defun soap-resolve-references-for-sequence-type (type wsdl) + "Resolve references for a sequence TYPE using WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let ((parent (soap-sequence-type-parent type))) + (when (or (consp parent) (stringp parent)) + (setf (soap-sequence-type-parent type) + (soap-wsdl-get parent wsdl 'soap-type-p)))) + (dolist (element (soap-sequence-type-elements type)) + (let ((element-type (soap-sequence-element-type element))) + (cond ((or (consp element-type) (stringp element-type)) + (setf (soap-sequence-element-type element) + (soap-wsdl-get element-type wsdl 'soap-type-p))) + ((soap-element-p element-type) + ;; since the element already has a child element, it + ;; could be an inline structure. we must resolve + ;; references in it, because it might not be reached by + ;; scanning the wsdl names. + (soap-resolve-references-for-element element-type wsdl)))))) + +(defun soap-resolve-references-for-array-type (type wsdl) + "Resolve references for an array TYPE using WSDL. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let ((element-type (soap-array-type-element-type type))) + (when (or (consp element-type) (stringp element-type)) + (setf (soap-array-type-element-type type) + (soap-wsdl-get element-type wsdl 'soap-type-p))))) + +(defun soap-resolve-references-for-message (message wsdl) + "Resolve references for a MESSAGE type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let (resolved-parts) + (dolist (part (soap-message-parts message)) + (let ((name (car part)) + (type (cdr part))) + (when (stringp name) + (setq name (intern name))) + (when (or (consp type) (stringp type)) + (setq type (soap-wsdl-get type wsdl 'soap-type-p))) + (push (cons name type) resolved-parts))) + (setf (soap-message-parts message) (nreverse resolved-parts)))) + +(defun soap-resolve-references-for-operation (operation wsdl) + "Resolve references for an OPERATION type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let ((input (soap-operation-input operation)) + (counter 0)) + (let ((name (car input)) + (message (cdr input))) + ;; Name this part if it was not named + (when (or (null name) (equal name "")) + (setq name (format "in%d" (incf counter)))) + (when (or (consp message) (stringp message)) + (setf (soap-operation-input operation) + (cons (intern name) (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((output (soap-operation-output operation)) + (counter 0)) + (let ((name (car output)) + (message (cdr output))) + (when (or (null name) (equal name "")) + (setq name (format "out%d" (incf counter)))) + (when (or (consp message) (stringp message)) + (setf (soap-operation-output operation) + (cons (intern name) (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((resolved-faults nil) + (counter 0)) + (dolist (fault (soap-operation-faults operation)) + (let ((name (car fault)) + (message (cdr fault))) + (when (or (null name) (equal name "")) + (setq name (format "fault%d" (incf counter)))) + (if (or (consp message) (stringp message)) + (push (cons (intern name) (soap-wsdl-get message wsdl 'soap-message-p)) + resolved-faults) + (push fault resolved-faults)))) + (setf (soap-operation-faults operation) resolved-faults)) + + (when (= (length (soap-operation-parameter-order operation)) 0) + (setf (soap-operation-parameter-order operation) + (mapcar 'car (soap-message-parts + (cdr (soap-operation-input operation)))))) + + (setf (soap-operation-parameter-order operation) + (mapcar (lambda (p) + (if (stringp p) + (intern p) + p)) + (soap-operation-parameter-order operation)))) + +(defun soap-resolve-references-for-binding (binding wsdl) + "Resolve references for a BINDING type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (when (or (consp (soap-binding-port-type binding)) + (stringp (soap-binding-port-type binding))) + (setf (soap-binding-port-type binding) + (soap-wsdl-get (soap-binding-port-type binding) wsdl 'soap-port-type-p))) + + (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding)))) + (maphash (lambda (k v) + (setf (soap-bound-operation-operation v) + (soap-namespace-get k port-ops 'soap-operation-p))) + (soap-binding-operations binding)))) + +(defun soap-resolve-references-for-port (port wsdl) + "Resolve references for a PORT type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (when (or (consp (soap-port-binding port)) + (stringp (soap-port-binding port))) + (setf (soap-port-binding port) + (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p)))) + +;; Install resolvers for our types +(progn + (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references + 'soap-resolve-references-for-sequence-type) + (put (aref (make-soap-array-type) 0) 'soap-resolve-references + 'soap-resolve-references-for-array-type) + (put (aref (make-soap-message) 0) 'soap-resolve-references + 'soap-resolve-references-for-message) + (put (aref (make-soap-operation) 0) 'soap-resolve-references + 'soap-resolve-references-for-operation) + (put (aref (make-soap-binding) 0) 'soap-resolve-references + 'soap-resolve-references-for-binding) + (put (aref (make-soap-port) 0) 'soap-resolve-references + 'soap-resolve-references-for-port)) + +(defun soap-wsdl-resolve-references (wsdl) + "Resolve all references inside the WSDL structure. + +When the WSDL elements are created from the XML document, they +refer to each other by name. For example, the ELEMENT-TYPE slot +of an SOAP-ARRAY-TYPE will contain the name of the element and +the user would have to call `soap-wsdl-get' to obtain the actual +element. + +After the entire document is loaded, we resolve all these +references to the actual elements they refer to so that at +runtime, we don't have to call `soap-wsdl-get' each time we +traverse an element tree." + (let ((nprocessed 0) + (nstag-id 0) + (alias-table (soap-wsdl-alias-table wsdl))) + (dolist (ns (soap-wsdl-namespaces wsdl)) + (let ((nstag (car-safe (rassoc (soap-namespace-name ns) alias-table)))) + (unless nstag + ;; If this namespace does not have an alias, create one for it. + (catch 'done + (while t + (setq nstag (format "ns%d" (incf nstag-id))) + (unless (assoc nstag alias-table) + (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl) + (throw 'done t))))) + + (maphash (lambda (name element) + (cond ((soap-element-p element) ; skip links + (incf nprocessed) + (soap-resolve-references-for-element element wsdl) + (setf (soap-element-namespace-tag element) nstag)) + ((listp element) + (dolist (e element) + (when (soap-element-p e) + (incf nprocessed) + (soap-resolve-references-for-element e wsdl) + (setf (soap-element-namespace-tag e) nstag)))))) + (soap-namespace-elements ns)))) + + (message "Processed %d" nprocessed)) + wsdl) + +;;;;; Loading WSDL from XML documents + +(defun soap-load-wsdl-from-url (url) + "Load a WSDL document from URL and return it. +The returned WSDL document needs to be used for `soap-invoke' +calls." + (let ((url-request-method "GET") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-request-coding-system 'utf-8) + (url-http-attempt-keepalives nil)) + (let ((buffer (url-retrieve-synchronously url))) + (with-current-buffer buffer + (declare (special url-http-response-status)) + (if (> url-http-response-status 299) + (error "Error retrieving WSDL: %s" url-http-response-status)) + (let ((mime-part (mm-dissect-buffer t t))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max))))) + (prog1 + (let ((wsdl (soap-parse-wsdl wsdl-xml))) + (setf (soap-wsdl-origin wsdl) url) + wsdl) + (kill-buffer buffer))))))))) + +(defun soap-load-wsdl (file) + "Load a WSDL document from FILE and return it." + (with-temp-buffer + (insert-file-contents file) + (let ((xml (car (xml-parse-region (point-min) (point-max))))) + (let ((wsdl (soap-parse-wsdl xml))) + (setf (soap-wsdl-origin wsdl) file) + wsdl)))) + +(defun soap-parse-wsdl (node) + "Construct a WSDL structure from NODE, which is an XML document." + (soap-with-local-xmlns node + + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions) + nil + "soap-parse-wsdl: expecting wsdl:definitions node, got %s" + (soap-l2wk (xml-node-name node))) + + (let ((wsdl (make-soap-wsdl))) + + ;; Add the local alias table to the wsdl document -- it will be used for + ;; all types in this document even after we finish parsing it. + (setf (soap-wsdl-alias-table wsdl) *soap-local-xmlns*) + + ;; Add the XSD types to the wsdl document + (let ((ns (soap-default-xsd-types))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl)) + + ;; Add the soapenc types to the wsdl document + (let ((ns (soap-default-soapenc-types))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl)) + + ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes + ;; and build our type-library + + (let ((types (car (soap-xml-get-children1 node 'wsdl:types)))) + (dolist (node (xml-node-children types)) + ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) + ;; because each node can install its own alias type so the schema + ;; nodes might have a different prefix. + (when (consp node) + (soap-with-local-xmlns node + (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + (soap-wsdl-add-namespace (soap-parse-schema node) wsdl)))))) + + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + (dolist (node (soap-xml-get-children1 node 'wsdl:message)) + (soap-namespace-put (soap-parse-message node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:portType)) + (let ((port-type (soap-parse-port-type node))) + (soap-namespace-put port-type ns) + (soap-wsdl-add-namespace (soap-port-type-operations port-type) wsdl))) + + (dolist (node (soap-xml-get-children1 node 'wsdl:binding)) + (soap-namespace-put (soap-parse-binding node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:service)) + (dolist (node (soap-xml-get-children1 node 'wsdl:port)) + (let ((name (xml-get-attribute node 'name)) + (binding (xml-get-attribute node 'binding)) + (url (let ((n (car (soap-xml-get-children1 node 'wsdlsoap:address)))) + (xml-get-attribute n 'location)))) + (let ((port (make-soap-port + :name name :binding (soap-l2fq binding 'tns) :service-url url))) + (soap-namespace-put port ns) + (push port (soap-wsdl-ports wsdl)))))) + + (soap-wsdl-add-namespace ns wsdl)) + + (soap-wsdl-resolve-references wsdl) + + wsdl))) + +(defun soap-parse-schema (node) + "Parse a schema NODE. +Return a SOAP-NAMESPACE containing the elements." + (soap-with-local-xmlns node + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + nil + "soap-parse-schema: expecting an xsd:schema node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + ;; NOTE: we only extract the complexTypes from the schema, we wouldn't + ;; know how to handle basic types beyond the built in ones anyway. + (dolist (node (soap-xml-get-children1 node 'xsd:complexType)) + (soap-namespace-put (soap-parse-complex-type node) ns)) + + (dolist (node (soap-xml-get-children1 node 'xsd:element)) + (soap-namespace-put (soap-parse-schema-element node) ns)) + + ns))) + +(defun soap-parse-schema-element (node) + "Parse NODE and construct a schema element from it." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element) + nil + "soap-parse-schema-element: expecting xsd:element node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + type) + ;; A schema element that contains an inline complex type -- + ;; construct the actual complex type for it. + (let ((type-node (soap-xml-get-children1 node 'xsd:complexType))) + (when (> (length type-node) 0) + (assert (= (length type-node) 1)) ; only one complex type definition per element + (setq type (soap-parse-complex-type (car type-node))))) + (setf (soap-element-name type) name) + type)) + +(defun soap-parse-complex-type (node) + "Parse NODE and construct a complex type from it." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType) + nil + "soap-parse-complex-type: expecting xsd:complexType node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + ;; Use a dummy type for the complex type, it will be replaced + ;; with the real type below, except when the complex type node + ;; is empty... + (type (make-soap-sequence-type :elements nil))) + (dolist (c (xml-node-children node)) + (when (consp c) ; skip string nodes, which are whitespace + (let ((node-name (soap-l2wk (xml-node-name c)))) + (cond + ((eq node-name 'xsd:sequence) + (setq type (soap-parse-complex-type-sequence c))) + ((eq node-name 'xsd:complexContent) + (setq type (soap-parse-complex-type-complex-content c))) + ((eq node-name 'xsd:attribute) + ;; The name of this node comes from an attribute tag + (let ((n (xml-get-attribute-or-nil c 'name))) + (setq name n))) + (t + (error "Unknown node type %s" node-name)))))) + (setf (soap-element-name type) name) + type)) + +(defun soap-parse-sequence (node) + "Parse NODE and a list of sequence elements that it defines. +NODE is assumed to be an xsd:sequence node. In that case, each +of its children is assumed to be a sequence element. Each +sequence element is parsed constructing the corresponding type. +A list of these types is returned." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:sequence) + nil + "soap-parse-sequence: expecting xsd:sequence node, got %s" + (soap-l2wk (xml-node-name node))) + (let (elements) + (dolist (e (soap-xml-get-children1 node 'xsd:element)) + (let ((name (xml-get-attribute-or-nil e 'name)) + (type (xml-get-attribute-or-nil e 'type)) + (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable) "true") + (let ((e (xml-get-attribute-or-nil e 'minOccurs))) + (and e (equal e "0"))))) + (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs))) + (and e (not (equal e "1")))))) + (if type + (setq type (soap-l2fq type 'tns)) + + ;; The node does not have a type, maybe it has a complexType + ;; defined inline... + (let ((type-node (soap-xml-get-children1 e 'xsd:complexType))) + (when (> (length type-node) 0) + (assert (= (length type-node) 1) + nil + "only one complex type definition per element supported") + (setq type (soap-parse-complex-type (car type-node)))))) + + (push (make-soap-sequence-element + :name (intern name) :type type :nillable? nillable? :multiple? multiple?) + elements))) + (nreverse elements))) + +(defun soap-parse-complex-type-sequence (node) + "Parse NODE as a sequence type." + (let ((elements (soap-parse-sequence node))) + (make-soap-sequence-type :elements elements))) + +(defun soap-parse-complex-type-complex-content (node) + "Parse NODE as a xsd:complexContent node. +A sequence or an array type is returned depending on the actual +contents." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent) + nil + "soap-parse-complex-type-complex-content: expecting xsd:complexContent node, got %s" + (soap-l2wk (xml-node-name node))) + (let (array? parent elements) + (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension))) + (restriction (car-safe (soap-xml-get-children1 node 'xsd:restriction)))) + ;; a complex content node is either an extension or a restriction + (cond (extension + (setq parent (xml-get-attribute-or-nil extension 'base)) + (setq elements (soap-parse-sequence + (car (soap-xml-get-children1 extension 'xsd:sequence))))) + (restriction + (let ((base (xml-get-attribute-or-nil restriction 'base))) + (assert (equal base "soapenc:Array") + nil + "restrictions supported only for soapenc:Array types, this is a %s" + base)) + (setq array? t) + (let ((attribute (car (soap-xml-get-children1 restriction 'xsd:attribute)))) + (let ((array-type (soap-xml-get-attribute-or-nil1 attribute 'wsdl:arrayType))) + (when (string-match "^\\(.*\\)\\[\\]$" array-type) + (setq parent (match-string 1 array-type)))))) + + (t + (error "Unknown complex type")))) + + (if parent + (setq parent (soap-l2fq parent 'tns))) + + (if array? + (make-soap-array-type :element-type parent) + (make-soap-sequence-type :parent parent :elements elements)))) + +(defun soap-parse-message (node) + "Parse NODE as a wsdl:message and return the corresponding type." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message) + nil + "soap-parse-message: expecting wsdl:message node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + parts) + (dolist (p (soap-xml-get-children1 node 'wsdl:part)) + (let ((name (xml-get-attribute-or-nil p 'name)) + (type (xml-get-attribute-or-nil p 'type)) + (element (xml-get-attribute-or-nil p 'element))) + + (when type + (setq type (soap-l2fq type 'tns))) + + (when element + (setq element (soap-l2fq element 'tns))) + + (push (cons name (or type element)) parts))) + (make-soap-message :name name :parts (nreverse parts)))) + +(defun soap-parse-port-type (node) + "Parse NODE as a wsdl:portType and return the corresponding port." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType) + nil + "soap-parse-port-type: expecting wsdl:portType node got %s" + (soap-l2wk (xml-node-name node))) + (let ((ns (make-soap-namespace + :name (concat "urn:" (xml-get-attribute node 'name))))) + (dolist (node (soap-xml-get-children1 node 'wsdl:operation)) + (let ((o (soap-parse-operation node))) + + (let ((other-operation (soap-namespace-get (soap-element-name o) ns 'soap-operation-p))) + (if other-operation + ;; Unfortunately, the Confluence WSDL defines two operations + ;; named "search" which differ only in parameter names... + (soap-warning "Discarding duplicate operation: %s" (soap-element-name o)) + + (progn + (soap-namespace-put o ns) + + ;; link all messages from this namespace, as this namespace + ;; will be used for decoding the response. + (destructuring-bind (name . message) (soap-operation-input o) + (soap-namespace-put-link name message ns)) + + (destructuring-bind (name . message) (soap-operation-output o) + (soap-namespace-put-link name message ns)) + + (dolist (fault (soap-operation-faults o)) + (destructuring-bind (name . message) fault + (soap-namespace-put-link name message ns 'replace))) + + ))))) + + (make-soap-port-type :name (xml-get-attribute node 'name) + :operations ns))) + +(defun soap-parse-operation (node) + "Parse NODE as a wsdl:operation and return the corresponding type." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation) + nil + "soap-parse-operation: expecting wsdl:operation node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute node 'name)) + (parameter-order (split-string (xml-get-attribute node 'parameterOrder))) + input output faults) + (dolist (n (xml-node-children node)) + (when (consp n) ; skip string nodes which are whitespace + (let ((node-name (soap-l2wk (xml-node-name n)))) + (cond + ((eq node-name 'wsdl:input) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (setq input (cons name (soap-l2fq message 'tns))))) + ((eq node-name 'wsdl:output) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (setq output (cons name (soap-l2fq message 'tns))))) + ((eq node-name 'wsdl:fault) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (push (cons name (soap-l2fq message 'tns)) faults))))))) + (make-soap-operation + :name name + :parameter-order parameter-order + :input input + :output output + :faults (nreverse faults)))) + +(defun soap-parse-binding (node) + "Parse NODE as a wsdl:binding and return the corresponding type." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding) + nil + "soap-parse-binding: expecting wsdl:binding node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute node 'name)) + (type (xml-get-attribute node 'type))) + (let ((binding (make-soap-binding :name name :port-type (soap-l2fq type 'tns)))) + (dolist (wo (soap-xml-get-children1 node 'wsdl:operation)) + (let ((name (xml-get-attribute wo 'name)) + soap-action + use) + (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation)) + (setq soap-action (xml-get-attribute-or-nil so 'soapAction))) + + ;; Search a wsdlsoap:body node and find a "use" tag. The + ;; same use tag is assumed to be present for both input and + ;; output types (although the WDSL spec allows separate + ;; "use"-s for each of them... + + (dolist (i (soap-xml-get-children1 wo 'wsdl:input)) + (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) + (setq use (or use + (xml-get-attribute-or-nil b 'use))))) + + (unless use + (dolist (i (soap-xml-get-children1 wo 'wsdl:output)) + (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) + (setq use (or use + (xml-get-attribute-or-nil b 'use)))))) + + (puthash name (make-soap-bound-operation :operation name + :soap-action soap-action + :use (and use (intern use))) + (soap-binding-operations binding)))) + binding))) + +;;;; SOAP type decoding + +(defvar *soap-multi-refs* nil + "The list of multi-ref nodes in the current SOAP response. +This is a dynamically bound variable used during decoding the +SOAP response.") + +(defvar *soap-decoded-multi-refs* nil + "List of decoded multi-ref nodes in the current SOAP response. +This is a dynamically bound variable used during decoding the +SOAP response.") + +(defvar *soap-current-wsdl* nil + "The current WSDL document used when decoding the SOAP response. +This is a dynamically bound variable.") + +(defun soap-decode-type (type node) + "Use TYPE (an xsd type) to decode the contents of NODE. + +NODE is an XML node, representing some SOAP encoded value or a +reference to another XML node (a multiRef). This function will +resolve the multiRef reference, if any, than call a TYPE specific +decode function to perform the actual decoding." + (let ((href (xml-get-attribute-or-nil node 'href))) + (cond (href + (catch 'done + ;; NODE is actually a HREF, find the target and decode that. + ;; Check first if we already decoded this multiref. + + (let ((decoded (cdr (assoc href *soap-decoded-multi-refs*)))) + (when decoded + (throw 'done decoded))) + + (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched + + (let ((id (match-string 1 href))) + (dolist (mr *soap-multi-refs*) + (let ((mrid (xml-get-attribute mr 'id))) + (when (equal id mrid) + ;; recurse here, in case there are multiple HREF's + (let ((decoded (soap-decode-type type mr))) + (push (cons href decoded) *soap-decoded-multi-refs*) + (throw 'done decoded))))) + (error "Cannot find href %s" href)))) + (t + (soap-with-local-xmlns node + (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true") + nil + (let ((decoder (get (aref type 0) 'soap-decoder))) + (assert decoder nil "no soap-decoder for %s type" (aref type 0)) + (funcall decoder type node)))))))) + +(defun soap-decode-any-type (node) + "Decode NODE using type information inside it." + ;; If the NODE has type information, we use that... + (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type))) + (if type + (let ((wtype (soap-wsdl-get type *soap-current-wsdl* 'soap-type-p))) + (if wtype + (soap-decode-type wtype node) + ;; The node has type info encoded in it, but we don't know how + ;; to decode it... + (error "Soap-decode-any-type: node has unknown type: %s" type))) + + ;; No type info in the node... + + (let ((contents (xml-node-children node))) + (if (and (= (length contents) 1) (stringp (car contents))) + ;; contents is just a string + (car contents) + + ;; we assume the NODE is a sequence with every element a + ;; structure name + (let (result) + (dolist (element contents) + (let ((key (xml-node-name element)) + (value (soap-decode-any-type element))) + (push (cons key value) result))) + (nreverse result))))))) + +(defun soap-decode-array (node) + "Decode NODE as an Array using type information inside it." + (let ((type (soap-xml-get-attribute-or-nil1 node 'soapenc:arrayType)) + (wtype nil) + (contents (xml-node-children node)) + result) + (when type + ;; Type is in the format "someType[NUM]" where NUM is the number of + ;; elements in the array. We discard the [NUM] part. + (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type)) + (setq wtype (soap-wsdl-get type *soap-current-wsdl* 'soap-type-p)) + (unless wtype + ;; The node has type info encoded in it, but we don't know how to + ;; decode it... + (error "Soap-decode-array: node has unknown type: %s" type))) + (dolist (e contents) + (when (consp e) + (push (if wtype + (soap-decode-type wtype e) + (soap-decode-any-type e)) + result))) + (nreverse result))) + +(defun soap-decode-basic-type (type node) + "Use TYPE to decode the contents of NODE. +TYPE is a `soap-basic-type' struct, and NODE is an XML document. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE." + (let ((contents (xml-node-children node)) + (type-kind (soap-basic-type-kind type))) + + (if (null contents) + nil + (ecase type-kind + (string (car contents)) + (dateTime (car contents)) ; TODO: convert to a date time + ((long int float) (string-to-number (car contents))) + (boolean (string= (downcase (car contents)) "true")) + (base64Binary (base64-decode-string (car contents))) + (anyType (soap-decode-any-type node)) + (Array (soap-decode-array node)))))) + +(defun soap-decode-sequence-type (type node) + "Use TYPE to decode the contents of NODE. +TYPE is assumed to be a sequence type and an ALIST with the +contents of the NODE is returned." + (let ((result nil) + (parent (soap-sequence-type-parent type))) + (when parent + (setq result (nreverse (soap-decode-type parent node)))) + (dolist (element (soap-sequence-type-elements type)) + (let ((instance-count 0) + (e-name (soap-sequence-element-name element)) + (e-type (soap-sequence-element-type element))) + (dolist (node (xml-get-children node e-name)) + (incf instance-count) + (push (cons e-name (soap-decode-type e-type node)) result)) + ;; Do some sanity checking + (cond ((and (= instance-count 0) + (not (soap-sequence-element-nillable? element))) + (soap-warning "While decoding %s: missing non-nillable slot %s" + (soap-element-name type) e-name)) + ((and (> instance-count 1) + (not (soap-sequence-element-multiple? element))) + (soap-warning "While decoding %s: multiple slots named %s" + (soap-element-name type) e-name))))) + (nreverse result))) + +(defun soap-decode-array-type (type node) + "Use TYPE to decode the contents of NODE. +TYPE is assumed to be an array type. Arrays are decoded as lists. +This is because it is easier to work with list results in LISP." + (let ((result nil) + (element-type (soap-array-type-element-type type))) + (dolist (node (xml-node-children node)) + (when (consp node) + (push (soap-decode-type element-type node) result))) + (nreverse result))) + +(progn + (put (aref (make-soap-basic-type) 0) + 'soap-decoder 'soap-decode-basic-type) + (put (aref (make-soap-sequence-type) 0) + 'soap-decoder 'soap-decode-sequence-type) + (put (aref (make-soap-array-type) 0) + 'soap-decoder 'soap-decode-array-type)) + +;;;; Soap Envelope parsing + +(put 'soap-error + 'error-conditions + '(error soap-error)) +(put 'soap-error 'error-message "SOAP error") + +(defun soap-parse-envelope (node operation wsdl) + "Parse the SOAP envelope in NODE and return the response. +OPERATION is the WSDL operation for which we expect the response, +WSDL is used to decode the NODE" + (soap-with-local-xmlns node + (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope) + nil + "soap-parse-envelope: expecting soap:Envelope node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((body (car (soap-xml-get-children1 node 'soap:Body)))) + + (let ((fault (car (soap-xml-get-children1 body 'soap:Fault)))) + (when fault + (let ((fault-code (let ((n (car (xml-get-children fault 'faultcode)))) + (car-safe (xml-node-children n)))) + (fault-string (let ((n (car (xml-get-children fault 'faultstring)))) + (car-safe (xml-node-children n))))) + (while t + (signal 'soap-error (list fault-code fault-string)))))) + + ;; First (non string) element of the body is the root node of he + ;; response + (let ((response (if (eq (soap-bound-operation-use operation) 'literal) + ;; For 'literal uses, the response is the actual body + body + ;; ...otherwise the first non string element + ;; of the body is the response + (catch 'found + (dolist (n (xml-node-children body)) + (when (consp n) + (throw 'found n))))))) + (soap-parse-response response operation wsdl body))))) + +(defun soap-parse-response (response-node operation wsdl soap-body) + "Parse RESPONSE-NODE and return the result as a LISP value. +OPERATION is the WSDL operation for which we expect the response, +WSDL is used to decode the NODE. + +SOAP-BODY is the body of the SOAP envelope (of which +RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE +reference multiRef parts which are external to RESPONSE-NODE." + (let* ((*soap-current-wsdl* wsdl) + (op (soap-bound-operation-operation operation)) + (use (soap-bound-operation-use operation)) + (message (cdr (soap-operation-output op)))) + + (soap-with-local-xmlns response-node + + (when (eq use 'encoded) + (let* ((received-message-name (soap-l2fq (xml-node-name response-node))) + (received-message (soap-wsdl-get received-message-name wsdl 'soap-message-p))) + (unless (eq received-message message) + (error "Unexpected message: got %s, expecting %s" + received-message-name + (soap-element-name message))))) + + (let ((decoded-parts nil) + (*soap-multi-refs* (xml-get-children soap-body 'multiRef)) + (*soap-decoded-multi-refs* nil)) + + (dolist (part (soap-message-parts message)) + (let ((tag (car part)) + (type (cdr part)) + node) + + (setq node + (cond + ((eq use 'encoded) + (car (xml-get-children response-node tag))) + + ((eq use 'literal) + (catch 'found + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc (soap-element-namespace-tag type) ns-aliases))) + (fqname (cons ns-name (soap-element-name type)))) + (dolist (c (xml-node-children response-node)) + (when (consp c) + (soap-with-local-xmlns c + (when (equal (soap-l2fq (xml-node-name c)) fqname) + (throw 'found c)))))))))) + + (unless node + (error "Soap-parse-response(%s): cannot find message part %s" + (soap-element-name op) tag)) + (push (soap-decode-type type node) decoded-parts))) + + decoded-parts)))) + +;;;; SOAP type encoding + +(defvar *soap-encoded-namespaces* nil + "A list of namespace tags used during encoding a message. +This list is populated by `soap-encode-value' and used by +`soap-create-envelope' to add aliases for these namespace to the +XML request. + +This variable is dynamically bound in `soap-create-envelope'.") + +(defun soap-encode-value (xml-tag value type) + "Encode inside an XML-TAG the VALUE using TYPE. +The resulting XML data is inserted in the current buffer +at (point)/ + +TYPE is one of the soap-*-type structures which defines how VALUE +is to be encoded. This is a generic function which finds an +encoder function based on TYPE and calls that encoder to do the +work." + (let ((encoder (get (aref type 0) 'soap-encoder))) + (assert encoder nil "no soap-encoder for %s type" (aref type 0)) + ;; XML-TAG can be a string or a symbol, but we pass only string's to the + ;; encoders + (when (symbolp xml-tag) + (setq xml-tag (symbol-name xml-tag))) + (funcall encoder xml-tag value type)) + (add-to-list '*soap-encoded-namespaces* (soap-element-namespace-tag type))) + +(defun soap-encode-basic-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (let ((xsi-type (soap-element-fq-name type)) + (basic-type (soap-basic-type-kind type))) + + ;; try to classify the type based on the value type and use that type when + ;; encoding + (when (eq basic-type 'anyType) + (cond ((stringp value) + (setq xsi-type "xsd:string" basic-type 'string)) + ((integerp value) + (setq xsi-type "xsd:int" basic-type 'int)) + ((memq value '(t nil)) + (setq xsi-type "xsd:boolean" basic-type 'boolean)) + (t + (error "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value" + xml-tag value xsi-type)))) + + (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") + + ;; We have some ambiguity here, as a nil value represents "false" when the + ;; type is boolean, we will never have a "nil" boolean type... + + (if (or value (eq basic-type 'boolean)) + (progn + (insert ">") + (case basic-type + (string + (unless (stringp value) + (error "Soap-encode-basic-type(%s, %s, %s): not a string value" + xml-tag value xsi-type)) + (insert (url-insert-entities-in-string value))) + + (dateTime + (cond ((and (consp value) ; is there a time-value-p ? + (>= (length value) 2) + (numberp (nth 0 value)) + (numberp (nth 1 value))) + ;; Value is a (current-time) style value, convert to a string + (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value))) + ((stringp value) + (insert (url-insert-entities-in-string value))) + (t + (error "Soap-encode-basic-type(%s, %s, %s): not a dateTime value" + xml-tag value xsi-type)))) + + (boolean + (unless (memq value '(t nil)) + (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value" + xml-tag value xsi-type)) + (insert (if value "true" "false"))) + + ((long int) + (unless (integerp value) + (error "Soap-encode-basic-type(%s, %s, %s): not an integer value" + xml-tag value xsi-type)) + (insert (number-to-string value))) + + (base64Binary + (unless (stringp value) + (error "Soap-encode-basic-type(%s, %s, %s): not a string value" + xml-tag value xsi-type)) + (insert (base64-encode-string value))) + + (otherwise + (error "Soap-encode-basic-type(%s, %s, %s): don't know how to encode" + xml-tag value xsi-type)))) + + (insert " xsi:nil=\"true\">")) + (insert "</" xml-tag ">\n"))) + +(defun soap-encode-sequence-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (let ((xsi-type (soap-element-fq-name type))) + (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") + (if value + (progn + (insert ">\n") + (let ((parents (list type)) + (parent (soap-sequence-type-parent type))) + + (while parent + (push parent parents) + (setq parent (soap-sequence-type-parent parent))) + + (dolist (type parents) + (dolist (element (soap-sequence-type-elements type)) + (let ((instance-count 0) + (e-name (soap-sequence-element-name element)) + (e-type (soap-sequence-element-type element))) + (dolist (v value) + (when (equal (car v) e-name) + (incf instance-count) + (soap-encode-value e-name (cdr v) e-type))) + + ;; Do some sanity checking + (cond ((and (= instance-count 0) + (not (soap-sequence-element-nillable? element))) + (soap-warning "While encoding %s: missing non-nillable slot %s" + (soap-element-name type) e-name)) + ((and (> instance-count 1) + (not (soap-sequence-element-multiple? element))) + (soap-warning "While encoding %s: multiple slots named %s" + (soap-element-name type) e-name)))))))) + (insert " xsi:nil=\"true\">")) + (insert "</" xml-tag ">\n"))) + +(defun soap-encode-array-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (unless (vectorp value) + (error "Soap-encode: %s(%s) expects a vector, got: %s" + xml-tag (soap-element-fq-name type) value)) + (let* ((element-type (soap-array-type-element-type type)) + (array-type (concat (soap-element-fq-name element-type) + "[" (format "%s" (length value)) "]"))) + (insert "<" xml-tag + " soapenc:arrayType=\"" array-type "\" " + " xsi:type=\"soapenc:Array\">\n") + (loop for i below (length value) + do (soap-encode-value xml-tag (aref value i) element-type)) + (insert "</" xml-tag ">\n"))) + +(progn + (put (aref (make-soap-basic-type) 0) + 'soap-encoder 'soap-encode-basic-type) + (put (aref (make-soap-sequence-type) 0) + 'soap-encoder 'soap-encode-sequence-type) + (put (aref (make-soap-array-type) 0) + 'soap-encoder 'soap-encode-array-type)) + +(defun soap-encode-body (operation parameters wsdl) + "Create the body of a SOAP request for OPERATION in the current buffer. +PARAMETERS is a list of parameters supplied to the OPERATION. + +The OPERATION and PARAMETERS are encoded according to the WSDL +document." + (let* ((op (soap-bound-operation-operation operation)) + (use (soap-bound-operation-use operation)) + (message (cdr (soap-operation-input op))) + (parameter-order (soap-operation-parameter-order op))) + + (unless (= (length parameter-order) (length parameters)) + (error "Wrong number of parameters for %s: expected %d, got %s" + (soap-element-name op) + (length parameter-order) + (length parameters))) + + (insert "<soap:Body>\n") + (when (eq use 'encoded) + (add-to-list '*soap-encoded-namespaces* (soap-element-namespace-tag op)) + (insert "<" (soap-element-fq-name op) ">\n")) + + (let ((param-table (loop for formal in parameter-order + for value in parameters + collect (cons formal value)))) + (dolist (part (soap-message-parts message)) + (let* ((param-name (car part)) + (type (cdr part)) + (tag-name (if (eq use 'encoded) + param-name + (soap-element-name type))) + (value (cdr (assoc param-name param-table))) + (start-pos (point))) + (soap-encode-value tag-name value type) + (when (eq use 'literal) + ;; hack: add the xmlns attribute to the tag, the only way + ;; ASP.NET web services recognize the namespace of the + ;; element itself... + (save-excursion + (goto-char start-pos) + (when (re-search-forward " ") + (let* ((ns (soap-element-namespace-tag type)) + (namespace (cdr (assoc ns (soap-wsdl-alias-table wsdl))))) + (when namespace + (insert "xmlns=\"" namespace "\" "))))))))) + + (when (eq use 'encoded) + (insert "</" (soap-element-fq-name op) ">\n")) + (insert "</soap:Body>\n"))) + +(defun soap-create-envelope (operation parameters wsdl) + "Create a SOAP request envelope for OPERATION using PARAMETERS. +WSDL is the wsdl document used to encode the PARAMETERS." + (with-temp-buffer + (let ((*soap-encoded-namespaces* '("xsi" "soap" "soapenc")) + (use (soap-bound-operation-use operation))) + + ;; Create the request body + (soap-encode-body operation parameters wsdl) + + ;; Put the envelope around the body + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n") + (when (eq use 'encoded) + (insert " soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n")) + (dolist (nstag *soap-encoded-namespaces*) + (insert " xmlns:" nstag "=\"") + (let ((nsname (cdr (assoc nstag *soap-well-known-xmlns*)))) + (unless nsname + (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl))))) + (insert nsname) + (insert "\"\n"))) + (insert ">\n") + (goto-char (point-max)) + (insert "</soap:Envelope>\n")) + + (buffer-string))) + +;;;; invoking soap methods + +(defcustom soap-debug nil + "When t, enable some debugging facilities." + :type 'boolean + :group 'soap-client) + +(defun soap-invoke (wsdl service operation-name &rest parameters) + "Invoke a SOAP operation and return the result. + +WSDL is used for encoding the request and decoding the response. +It also contains information about the WEB server address that +will service the request. + +SERVICE is the SOAP service to invoke. + +OPERATION-NAME is the operation to invoke. + +PARAMETERS -- the remaining parameters are used as parameters for +the SOAP request. + +NOTE: The SOAP service provider should document the available +operations and their parameters for the service. You can also +use the `soap-inspect' function to browse the available +operations in a WSDL document." + (let ((port (catch 'found + (dolist (p (soap-wsdl-ports wsdl)) + (when (equal service (soap-element-name p)) + (throw 'found p)))))) + (unless port + (error "Unknown SOAP service: %s" service)) + + (let* ((binding (soap-port-binding port)) + (operation (gethash operation-name (soap-binding-operations binding)))) + (unless operation + (error "No operation %s for SOAP service %s" operation-name service)) + + (let ((url-request-method "POST") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-http-version "1.0") + (url-request-data (soap-create-envelope operation parameters wsdl)) + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-request-coding-system 'utf-8) + (url-http-attempt-keepalives t) + (url-request-extra-headers (list + (cons "SOAPAction" (soap-bound-operation-soap-action operation)) + (cons "Content-Type" "text/xml; charset=utf-8")))) + (let ((buffer (url-retrieve-synchronously (soap-port-service-url port)))) + (condition-case err + (with-current-buffer buffer + (declare (special url-http-response-status)) + (if (null url-http-response-status) + (error "No HTTP response from server")) + (if (and soap-debug (> url-http-response-status 299)) + ;; This is a warning because some SOAP errors come + ;; back with a HTTP response 500 (internal server + ;; error) + (warn "Error in SOAP response: HTTP code %s" url-http-response-status)) + (when (> (buffer-size) 1000000) + (soap-warning "Received large message: %s bytes" (buffer-size))) + (let ((mime-part (mm-dissect-buffer t t))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (let ((response (car (xml-parse-region (point-min) (point-max))))) + (prog1 + (soap-parse-envelope response operation wsdl) + (kill-buffer buffer) + (mm-destroy-part mime-part)))))) + (soap-error + ;; Propagate soap-errors -- they are error replies of the + ;; SOAP protocol and don't indicate a communication + ;; problem or a bug in this code. + (signal (car err) (cdr err))) + (error + (when soap-debug + (pop-to-buffer buffer)) + (error (error-message-string err))))))))) + +(provide 'soap-client) + + +;;; Local Variables: +;;; mode: emacs-lisp +;;; mode: outline-minor +;;; outline-regexp: ";;;;+" +;;; End: + +;;; 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 @@ +;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures + +;; Copyright (C) 2010-2011 Alex Harsanyi <AlexHarsanyi@gmail.com> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com) +;; Created: October 2010 +;; Keywords: soap, web-services +;; Homepage: http://code.google.com/p/emacs-soap-client +;; + +;;; Commentary: +;; +;; This package provides an inspector for a WSDL document loaded with +;; `soap-load-wsdl' or `soap-load-wsdl-from-url'. To use it, evaluate: +;; +;; (soap-inspect *wsdl*) +;; +;; This will pop-up the inspector buffer. You can click on ports, operations +;; and types to explore the structure of the wsdl document. +;; + +(require 'soap-client) + + +;;; Code: + +;;; sample-value + +(defun soap-sample-value (type) + "Provide a sample value for TYPE, a WSDL type. +A sample value is a LISP value which soap-client.el will accept +for encoding it using TYPE when making SOAP requests. + +This is a generic function, depending on TYPE a specific function +will be called." + (let ((sample-value (get (aref type 0) 'soap-sample-value))) + (if sample-value + (funcall sample-value type) + (error "Cannot provide sample value for type %s" (aref type 0))))) + +(defun soap-sample-value-for-basic-type (type) + "Provide a sample value for TYPE which is a basic type. +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + (case (soap-basic-type-kind type) + (string "a string value") + (boolean t) ; could be nil as well + ((long int) (random 4200)) + ;; TODO: we need better sample values for more types. + (t (format "%s" (soap-basic-type-kind type))))) + +(defun soap-sample-value-for-seqence-type (type) + "Provide a sample value for TYPE which is a sequence type. +Values for sequence types are ALISTS of (slot-name . VALUE) for +each sequence element. + +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + (let ((sample-value nil)) + (dolist (element (soap-sequence-type-elements type)) + (push (cons (soap-sequence-element-name element) + (soap-sample-value (soap-sequence-element-type element))) + sample-value)) + (when (soap-sequence-type-parent type) + (setq sample-value + (append (soap-sample-value (soap-sequence-type-parent type)) + sample-value))) + sample-value)) + +(defun soap-sample-value-for-array-type (type) + "Provide a sample value for TYPE which is an array type. +Values for array types are LISP vectors of values which are +array's element type. + +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + (let* ((element-type (soap-array-type-element-type type)) + (sample1 (soap-sample-value element-type)) + (sample2 (soap-sample-value element-type))) + ;; Our sample value is a vector of two elements, but any number of + ;; elements are permissible + (vector sample1 sample2 '&etc))) + +(defun soap-sample-value-for-message (message) + "Provide a sample value for a WSDL MESSAGE. +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + ;; NOTE: parameter order is not considered. + (let (sample-value) + (dolist (part (soap-message-parts message)) + (push (cons (car part) + (soap-sample-value (cdr part))) + sample-value)) + (nreverse sample-value))) + +(progn + ;; Install soap-sample-value methods for our types + (put (aref (make-soap-basic-type) 0) 'soap-sample-value + 'soap-sample-value-for-basic-type) + + (put (aref (make-soap-sequence-type) 0) 'soap-sample-value + 'soap-sample-value-for-seqence-type) + + (put (aref (make-soap-array-type) 0) 'soap-sample-value + 'soap-sample-value-for-array-type) + + (put (aref (make-soap-message) 0) 'soap-sample-value + 'soap-sample-value-for-message) ) + + + +;;; soap-inspect + +(defvar soap-inspect-previous-items nil + "A stack of previously inspected items in the *soap-inspect* buffer. +Used to implement the BACK button.") + +(defvar soap-inspect-current-item nil + "The current item being inspected in the *soap-inspect* buffer.") + +(progn + (make-variable-buffer-local 'soap-inspect-previous-items) + (make-variable-buffer-local 'soap-inspect-current-item)) + +(defun soap-inspect (element) + "Inspect a SOAP ELEMENT in the *soap-inspect* buffer. +The buffer is populated with information about ELEMENT with links +to its sub elements. If ELEMENT is the WSDL document itself, the +entire WSDL can be inspected." + (let ((inspect (get (aref element 0) 'soap-inspect))) + (unless inspect + (error "Soap-inspect: no inspector for element")) + + (with-current-buffer (get-buffer-create "*soap-inspect*") + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + + (when soap-inspect-current-item + (push soap-inspect-current-item + soap-inspect-previous-items)) + (setq soap-inspect-current-item element) + + (funcall inspect element) + + (unless (null soap-inspect-previous-items) + (insert "\n\n") + (insert-text-button + "[back]" + 'type 'soap-client-describe-back-link + 'item element) + (insert "\n")) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)))))) + + +(define-button-type 'soap-client-describe-link + 'face 'italic + 'help-echo "mouse-2, RET: describe item" + 'follow-link t + 'action (lambda (button) + (let ((item (button-get button 'item))) + (soap-inspect item))) + 'skip t) + +(define-button-type 'soap-client-describe-back-link + 'face 'italic + 'help-echo "mouse-2, RET: browse the previous item" + 'follow-link t + 'action (lambda (button) + (let ((item (pop soap-inspect-previous-items))) + (when item + (setq soap-inspect-current-item nil) + (soap-inspect item)))) + 'skip t) + +(defun soap-insert-describe-button (element) + "Insert a button to inspect ELEMENT when pressed." + (insert-text-button + (soap-element-fq-name element) + 'type 'soap-client-describe-link + 'item element)) + +(defun soap-inspect-basic-type (basic-type) + "Insert information about BASIC-TYPE into the current buffer." + (insert "Basic type: " (soap-element-fq-name basic-type)) + (insert "\nSample value\n") + (pp (soap-sample-value basic-type) (current-buffer))) + +(defun soap-inspect-sequence-type (sequence) + "Insert information about SEQUENCE into the current buffer." + (insert "Sequence type: " (soap-element-fq-name sequence) "\n") + (when (soap-sequence-type-parent sequence) + (insert "Parent: ") + (soap-insert-describe-button + (soap-sequence-type-parent sequence)) + (insert "\n")) + (insert "Elements: \n") + (dolist (element (soap-sequence-type-elements sequence)) + (insert "\t" (symbol-name (soap-sequence-element-name element)) + "\t") + (soap-insert-describe-button + (soap-sequence-element-type element)) + (when (soap-sequence-element-multiple? element) + (insert " multiple")) + (when (soap-sequence-element-nillable? element) + (insert " optional")) + (insert "\n")) + (insert "Sample value:\n") + (pp (soap-sample-value sequence) (current-buffer))) + +(defun soap-inspect-array-type (array) + "Insert information about the ARRAY into the current buffer." + (insert "Array name: " (soap-element-fq-name array) "\n") + (insert "Element type: ") + (soap-insert-describe-button + (soap-array-type-element-type array)) + (insert "\nSample value:\n") + (pp (soap-sample-value array) (current-buffer))) + +(defun soap-inspect-message (message) + "Insert information about MESSAGE into the current buffer." + (insert "Message name: " (soap-element-fq-name message) "\n") + (insert "Parts:\n") + (dolist (part (soap-message-parts message)) + (insert "\t" (symbol-name (car part)) + " type: ") + (soap-insert-describe-button (cdr part)) + (insert "\n"))) + +(defun soap-inspect-operation (operation) + "Insert information about OPERATION into the current buffer." + (insert "Operation name: " (soap-element-fq-name operation) "\n") + (let ((input (soap-operation-input operation))) + (insert "\tInput: " (symbol-name (car input)) " (" ) + (soap-insert-describe-button (cdr input)) + (insert ")\n")) + (let ((output (soap-operation-output operation))) + (insert "\tOutput: " (symbol-name (car output)) " (") + (soap-insert-describe-button (cdr output)) + (insert ")\n")) + + (insert "\n\nSample invocation:\n") + (let ((sample-message-value (soap-sample-value (cdr (soap-operation-input operation)))) + (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation)))) + (let ((sample-invocation (append funcall (mapcar 'cdr sample-message-value)))) + (pp sample-invocation (current-buffer))))) + +(defun soap-inspect-port-type (port-type) + "Insert information about PORT-TYPE into the current buffer." + (insert "Port-type name: " (soap-element-fq-name port-type) "\n") + (insert "Operations:\n") + (loop for o being the hash-values of + (soap-namespace-elements (soap-port-type-operations port-type)) + do (progn + (insert "\t") + (soap-insert-describe-button (car o))))) + +(defun soap-inspect-binding (binding) + "Insert information about BINDING into the current buffer." + (insert "Binding: " (soap-element-fq-name binding) "\n") + (insert "\n") + (insert "Bound operations:\n") + (let* ((ophash (soap-binding-operations binding)) + (operations (loop for o being the hash-keys of ophash + collect o)) + op-name-width) + + (setq operations (sort operations 'string<)) + + (setq op-name-width (loop for o in operations maximizing (length o))) + + (dolist (op operations) + (let* ((bound-op (gethash op ophash)) + (soap-action (soap-bound-operation-soap-action bound-op)) + (use (soap-bound-operation-use bound-op))) + (unless soap-action + (setq soap-action "")) + (insert "\t") + (soap-insert-describe-button (soap-bound-operation-operation bound-op)) + (when (or use (not (equal soap-action ""))) + (insert (make-string (- op-name-width (length op)) ?\s)) + (insert " (") + (insert soap-action) + (when use + (insert " " (symbol-name use))) + (insert ")")) + (insert "\n"))))) + +(defun soap-inspect-port (port) + "Insert information about PORT into the current buffer." + (insert "Port name: " (soap-element-name port) "\n" + "Service URL: " (soap-port-service-url port) "\n" + "Binding: ") + (soap-insert-describe-button (soap-port-binding port))) + +(defun soap-inspect-wsdl (wsdl) + "Insert information about WSDL into the current buffer." + (insert "WSDL Origin: " (soap-wsdl-origin wsdl) "\n") + (insert "Ports:") + (dolist (p (soap-wsdl-ports wsdl)) + (insert "\n--------------------\n") + ;; (soap-insert-describe-button p) + (soap-inspect-port p)) + (insert "\n--------------------\nNamespace alias table:\n") + (dolist (a (soap-wsdl-alias-table wsdl)) + (insert "\t" (car a) " => " (cdr a) "\n"))) + +(progn + ;; Install the soap-inspect methods for our types + + (put (aref (make-soap-basic-type) 0) 'soap-inspect + 'soap-inspect-basic-type) + + (put (aref (make-soap-sequence-type) 0) 'soap-inspect + 'soap-inspect-sequence-type) + + (put (aref (make-soap-array-type) 0) 'soap-inspect + 'soap-inspect-array-type) + + (put (aref (make-soap-message) 0) 'soap-inspect + 'soap-inspect-message) + (put (aref (make-soap-operation) 0) 'soap-inspect + 'soap-inspect-operation) + + (put (aref (make-soap-port-type) 0) 'soap-inspect + 'soap-inspect-port-type) + + (put (aref (make-soap-binding) 0) 'soap-inspect + 'soap-inspect-binding) + + (put (aref (make-soap-port) 0) 'soap-inspect + 'soap-inspect-port) + + (put (aref (make-soap-wsdl) 0) 'soap-inspect + 'soap-inspect-wsdl)) + +(provide 'soap-inspect) +;;; soap-inspect.el ends here |