lisp/net/soap-client.el

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