-;;;; soap.el -- Access SOAP web services from Emacs
+;;;; soap-client.el -- Access SOAP web services from Emacs
-;; Copyright (C) 2009-2011 Alex Harsanyi <AlexHarsanyi@gmail.com>
+;; Copyright (C) 2009-2012 Free Software Foundation, Inc.
-;; This program is free software: you can redistribute it and/or modify
+;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
+;; Created: December, 2009
+;; Keywords: soap, web-services, comm, hypermedia
+;; Package: soap-client
+;; Homepage: http://code.google.com/p/emacs-soap-client
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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,
+;; GNU Emacs 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
-;;
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; 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
;; `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
+;; Ideally, 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.
(defgroup soap-client nil
"Access SOAP web services from Emacs."
+ :version "24.1"
:group 'tools)
;;;; Support for parsing XML documents with namespaces
;; "well known" namespace tag and the local namespace tag in the document
;; being parsed.
-(defconst *soap-well-known-xmlns*
+(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/")
("mime" . "http://schemas.xmlsoap.org/wsdl/mime/"))
"A list of well known xml namespaces and their aliases.")
-(defvar *soap-local-xmlns* nil
+(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
+(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
+(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
(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
+`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'."
+`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)))
((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*)
+ (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*)))
+ (let* ((local-ns (car (rassoc namespace soap-local-xmlns)))
(local-name (concat local-ns ":" name)))
(if (symbolp well-known-name)
(intern local-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
+`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
((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*)))
+ (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*)))
+ (setq namespace soap-default-xmlns)))
(if namespace
- (let ((well-known-ns (car (rassoc namespace *soap-well-known-xmlns*))))
+ (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)
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\"
-\).
+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*'
+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.
+`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."
(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*))))
+ (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*)
+ soap-target-xmlns
+ soap-default-xmlns)
local-name)))))
(defun soap-extract-xmlns (node &optional xmlns-table)
(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.
+ ;; 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))))
+ (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)
;; 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)))
+ `(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*))
+ (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.
;; 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)))
+ (eq (ignore-errors (soap-l2wk (xml-node-name c)))
+ child-name)))
(push c result)))
(nreverse result)))
;; if name is nil, use TARGET as a name...
(cond ((soap-element-p target)
(setq name (soap-element-name target)))
+ ((consp target) ; a fq name: (namespace . name)
+ (setq name (cdr 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
+ ;; by now, name should be valid
+ (assert (and name (not (equal name "")))
+ nil
+ "Cannot determine name for namespace link")
(push (make-soap-namespace-link :name name :target target)
(gethash name (soap-namespace-elements ns))))
(throw 'found e)))))
((= (length elements) 1) (car elements))
((> (length elements) 1)
- (error "Soap-namespace-get(%s): multiple elements, discriminant needed" name))
+ (error
+ "Soap-namespace-get(%s): multiple elements, discriminant needed"
+ name))
(t
nil))))
kind ; a symbol of: string, dateTime, long, int
)
+(defstruct (soap-simple-type (:include soap-basic-type))
+ enumeration)
+
(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
+ elements ; LIST of SOAP-SEQUENCE-ELEMENT
)
(defstruct (soap-array-type (:include soap-element))
(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
+ use ; 'literal or 'encoded, see
+ ; http://www.w3.org/TR/wsdl#_soap:body
)
(defstruct (soap-binding (:include soap-element))
(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[]"))
+ (dolist (type '("string" "dateTime" "boolean"
+ "long" "int" "integer" "unsignedInt" "byte" "float" "double"
+ "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
(soap-namespace-put
(make-soap-basic-type :name type :kind (intern type))
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[]"))
+ (let ((ns (make-soap-namespace
+ :name "http://schemas.xmlsoap.org/soap/encoding/")))
+ (dolist (type '("string" "dateTime" "boolean"
+ "long" "int" "integer" "unsignedInt" "byte" "float" "double"
+ "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
(soap-namespace-put
(make-soap-basic-type :name type :kind (intern type))
ns))
(or (soap-basic-type-p element)
(soap-sequence-type-p element)
(soap-array-type-p element)))
-
+
;;;;; The WSDL document
(soap-wsdl-get \"foo\" WSDL 'soap-message-p)
-If USE-LOCAL-ALIAS-TABLE is not nil, `*soap-local-xmlns*` will be
+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)
(setq name (symbol-name name)))
(when use-local-alias-table
- (setq alias-table (append *soap-local-xmlns* 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 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))
-
+ (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))))
+ (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)))
(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)
(when resolver
(funcall resolver element wsdl))))
+(defun soap-resolve-references-for-simple-type (type wsdl)
+ "Resolve the base type for the simple TYPE using the WSDL
+ document."
+ (let ((kind (soap-basic-type-kind type)))
+ (unless (symbolp kind)
+ (let ((basic-type (soap-wsdl-get kind wsdl 'soap-basic-type-p)))
+ (setf (soap-basic-type-kind type)
+ (soap-basic-type-kind basic-type))))))
+
(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
(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))))
+ (soap-wsdl-get
+ parent wsdl
+ ;; Prevent self references, see Bug#9
+ (lambda (e) (and (not (eq e type)) (soap-type-p e)))))))
(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-wsdl-get
+ element-type wsdl
+ ;; Prevent self references, see Bug#9
+ (lambda (e) (and (not (eq e type)) (soap-type-p e))))))
((soap-element-p element-type)
;; since the element already has a child element, it
;; could be an inline structure. we must resolve
(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)))))
+ (soap-wsdl-get
+ element-type wsdl
+ ;; Prevent self references, see Bug#9
+ (lambda (e) (and (not (eq e type)) (soap-type-p e))))))))
(defun soap-resolve-references-for-message (message wsdl)
"Resolve references for a MESSAGE type using the WSDL document.
(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))))))
+ (cons (intern name)
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
(let ((output (soap-operation-output operation))
(counter 0))
(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))))))
+ (cons (intern name)
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
(let ((resolved-faults nil)
(counter 0))
(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))
+ (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))
(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)
(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)))
+ (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)
;; Install resolvers for our types
(progn
+ (put (aref (make-soap-simple-type) 0) 'soap-resolve-references
+ 'soap-resolve-references-for-simple-type)
(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
(incf nprocessed)
(soap-resolve-references-for-element e wsdl)
(setf (soap-element-namespace-tag e) nstag))))))
- (soap-namespace-elements ns))))
-
- (message "Processed %d" nprocessed))
+ (soap-namespace-elements ns)))))
wsdl)
;;;;; Loading WSDL from XML documents
;; 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*)
+ (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns)
;; Add the XSD types to the wsdl document
(let ((ns (soap-default-xsd-types)))
(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)))
+ (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: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))))
+ (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)))
+ :name name :binding (soap-l2fq binding 'tns)
+ :service-url url)))
(soap-namespace-put port ns)
(push port (soap-wsdl-ports wsdl))))))
(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:simpleType))
+ (soap-namespace-put (soap-parse-simple-type node) ns))
+
(dolist (node (soap-xml-get-children1 node 'xsd:complexType))
(soap-namespace-put (soap-parse-complex-type node) ns))
ns)))
+(defun soap-parse-simple-type (node)
+ "Parse NODE and construct a simple type from it."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:simpleType)
+ nil
+ "soap-parse-complex-type: expecting xsd:simpleType node, got %s"
+ (soap-l2wk (xml-node-name node)))
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ type
+ enumeration
+ (restriction (car-safe
+ (soap-xml-get-children1 node 'xsd:restriction))))
+ (unless restriction
+ (error "simpleType %s has no base type" name))
+
+ (setq type (xml-get-attribute-or-nil restriction 'base))
+ (dolist (e (soap-xml-get-children1 restriction 'xsd:enumeration))
+ (push (xml-get-attribute e 'value) enumeration))
+
+ (make-soap-simple-type :name name :kind type :enumeration enumeration)))
+
(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)
;; 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
+ (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))
(when (consp c) ; skip string nodes, which are whitespace
(let ((node-name (soap-l2wk (xml-node-name c))))
(cond
- ((eq node-name 'xsd:sequence)
+ ;; The difference between xsd:all and xsd:sequence is that fields
+ ;; in xsd:all are not ordered and they can occur only once. We
+ ;; don't care about that difference in soap-client.el
+ ((or (eq node-name 'xsd:sequence)
+ (eq node-name 'xsd:all))
(setq type (soap-parse-complex-type-sequence c)))
((eq node-name 'xsd:complexContent)
(setq type (soap-parse-complex-type-complex-content c)))
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)
+ (assert (let ((n (soap-l2wk (xml-node-name node))))
+ (memq n '(xsd:sequence xsd:all)))
nil
- "soap-parse-sequence: expecting xsd:sequence node, got %s"
+ "soap-parse-sequence: expecting xsd:sequence or xsd:all node, got %s"
(soap-l2wk (xml-node-name node)))
(let (elements)
(dolist (e (soap-xml-get-children1 node 'xsd:element))
(setq type (soap-parse-complex-type (car type-node))))))
(push (make-soap-sequence-element
- :name (intern name) :type type :nillable? nillable? :multiple? multiple?)
+ :name (intern name) :type type :nillable? nillable?
+ :multiple? multiple?)
elements)))
(nreverse elements)))
(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))))
+ (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)))))
+ (car (soap-xml-get-children1
+ extension 'xsd:sequence)))))
(restriction
(let ((base (xml-get-attribute-or-nil restriction 'base)))
- (assert (equal base "soapenc:Array")
+ (assert (equal base (soap-wk2l "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)))
+ (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))))))
(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))))
(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)))
+ (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))
+ (soap-warning "Discarding duplicate operation: %s"
+ (soap-element-name o))
(progn
(soap-namespace-put o ns)
"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)))
+ (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
(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))))
+ (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
;;;; SOAP type decoding
-(defvar *soap-multi-refs* nil
+(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
+(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
+(defvar soap-current-wsdl nil
"The current WSDL document used when decoding the SOAP response.
This is a dynamically bound variable.")
;; 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*))))
+ (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*)
+ (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*)
+ (push (cons href decoded) soap-decoded-multi-refs)
(throw 'done decoded)))))
(error "Cannot find href %s" href))))
(t
(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))
+ (assert decoder nil "no soap-decoder for %s type"
+ (aref type 0))
(funcall decoder type node))))))))
(defun soap-decode-any-type (node)
;; 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)))
+ (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
;; 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))
+ (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...
(if (null contents)
nil
(ecase type-kind
- (string (car contents))
+ ((string anyURI) (car contents))
(dateTime (car contents)) ; TODO: convert to a date time
- ((long int float) (string-to-number (car contents)))
+ ((long int integer unsignedInt byte float double) (string-to-number (car contents)))
(boolean (string= (downcase (car contents)) "true"))
(base64Binary (base64-decode-string (car contents)))
(anyType (soap-decode-any-type node))
(progn
(put (aref (make-soap-basic-type) 0)
'soap-decoder 'soap-decode-basic-type)
+ ;; just use the basic type decoder for the simple type -- we accept any
+ ;; value and don't do any validation on it.
+ (put (aref (make-soap-simple-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)
(let ((fault (car (soap-xml-get-children1 body 'soap:Fault))))
(when fault
- (let ((fault-code (let ((n (car (xml-get-children fault 'faultcode))))
+ (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)))))
+ (fault-string (let ((n (car (xml-get-children
+ fault 'faultstring))))
+ (car-safe (xml-node-children n))))
+ (detail (xml-get-children fault 'detail)))
(while t
- (signal 'soap-error (list fault-code fault-string))))))
+ (signal 'soap-error (list fault-code fault-string detail))))))
;; First (non string) element of the body is the root node of he
;; response
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)
+ (let* ((soap-current-wsdl wsdl)
(op (soap-bound-operation-operation operation))
(use (soap-bound-operation-use operation))
(message (cdr (soap-operation-output op))))
(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)))
+ (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))
+ (soap-multi-refs (xml-get-children soap-body 'multiRef))
+ (soap-decoded-multi-refs nil))
(dolist (part (soap-message-parts message))
(let ((tag (car part))
((eq use 'literal)
(catch 'found
(let* ((ns-aliases (soap-wsdl-alias-table wsdl))
- (ns-name (cdr (assoc (soap-element-namespace-tag type) ns-aliases)))
+ (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)
+ (when (equal (soap-l2fq (xml-node-name c))
+ fqname)
(throw 'found c))))))))))
(unless node
;;;; SOAP type encoding
-(defvar *soap-encoded-namespaces* nil
+(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
(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)))
+ (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.
((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))))
+ (error
+ "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value"
+ xml-tag value xsi-type))))
(insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
(progn
(insert ">")
(case basic-type
- (string
+ ((string anyURI)
(unless (stringp value)
(error "Soap-encode-basic-type(%s, %s, %s): not a string value"
xml-tag value xsi-type))
(>= (length value) 2)
(numberp (nth 0 value))
(numberp (nth 1 value)))
- ;; Value is a (current-time) style value, convert to a string
+ ;; 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))))
+ (error
+ "Soap-encode-basic-type(%s, %s, %s): not a dateTime value"
+ xml-tag value xsi-type))))
(boolean
(unless (memq value '(t nil))
xml-tag value xsi-type))
(insert (if value "true" "false")))
- ((long int)
+ ((long int integer byte unsignedInt)
(unless (integerp value)
(error "Soap-encode-basic-type(%s, %s, %s): not an integer value"
xml-tag value xsi-type))
+ (when (and (eq basic-type 'unsignedInt) (< value 0))
+ (error "Soap-encode-basic-type(%s, %s, %s): not a positive integer"
+ xml-tag value xsi-type))
(insert (number-to-string value)))
-
+
+ ((float double)
+ (unless (numberp value)
+ (error "Soap-encode-basic-type(%s, %s, %s): not a number"
+ 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"
(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))))
-
+ (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-simple-type (xml-tag value type)
+ "Encode inside XML-TAG the LISP VALUE according to TYPE."
+
+ ;; Validate VALUE against the simple type's enumeration, than just encode it
+ ;; using `soap-encode-basic-type'
+
+ (let ((enumeration (soap-simple-type-enumeration type)))
+ (unless (and (> (length enumeration) 1)
+ (member value enumeration))
+ (error "soap-encode-simple-type(%s, %s, %s): bad value, should be one of %s"
+ xml-tag value (soap-element-fq-name type) enumeration)))
+
+ (soap-encode-basic-type xml-tag value type))
+
(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'
;; 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))
+ (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))))))))
+ (soap-warning
+ "While encoding %s: multiple slots named %s"
+ (soap-element-name type) e-name))))))))
(insert " xsi:nil=\"true\">"))
(insert "</" xml-tag ">\n")))
(progn
(put (aref (make-soap-basic-type) 0)
'soap-encoder 'soap-encode-basic-type)
+ (put (aref (make-soap-simple-type) 0)
+ 'soap-encoder 'soap-encode-simple-type)
(put (aref (make-soap-sequence-type) 0)
'soap-encoder 'soap-encode-sequence-type)
(put (aref (make-soap-array-type) 0)
(insert "<soap:Body>\n")
(when (eq use 'encoded)
- (add-to-list '*soap-encoded-namespaces* (soap-element-namespace-tag op))
+ (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
(goto-char start-pos)
(when (re-search-forward " ")
(let* ((ns (soap-element-namespace-tag type))
- (namespace (cdr (assoc ns (soap-wsdl-alias-table wsdl)))))
+ (namespace (cdr (assoc ns
+ (soap-wsdl-alias-table wsdl)))))
(when namespace
(insert "xmlns=\"" namespace "\" ")))))))))
"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"))
+ (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc"))
(use (soap-bound-operation-use operation)))
;; Create the request body
(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*)
+ (dolist (nstag soap-encoded-namespaces)
(insert " xmlns:" nstag "=\"")
- (let ((nsname (cdr (assoc nstag *soap-well-known-xmlns*))))
+ (let ((nsname (cdr (assoc nstag soap-well-known-xmlns))))
(unless nsname
(setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl)))))
(insert nsname)
(error "Unknown SOAP service: %s" service))
(let* ((binding (soap-port-binding port))
- (operation (gethash operation-name (soap-binding-operations binding))))
+ (operation (gethash operation-name
+ (soap-binding-operations binding))))
(unless operation
(error "No operation %s for SOAP service %s" operation-name service))
(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))))
+ (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))
;; 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)))
+ (warn "Error in SOAP response: HTTP code %s"
+ url-http-response-status))
(let ((mime-part (mm-dissect-buffer t t)))
(unless mime-part
(error "Failed to decode response from server"))
(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)))))
+ (let ((response (car (xml-parse-region
+ (point-min) (point-max)))))
(prog1
(soap-parse-envelope response operation wsdl)
(kill-buffer buffer)
\f
;;; Local Variables:
-;;; mode: emacs-lisp
-;;; mode: outline-minor
+;;; eval: (outline-minor-mode 1)
;;; outline-regexp: ";;;;+"
;;; End: