>From e87c51ad1453bea495daf5216e6c13da490c45d9 Mon Sep 17 00:00:00 2001 From: Thomas Fitzsimmons Date: Fri, 23 Oct 2015 10:01:53 -0400 Subject: [PATCH] Sync with soap-client repository, version 3.0.0 --- lisp/net/soap-client.el | 3181 ++++++++++++++++++++++++++++++++-------------- lisp/net/soap-inspect.el | 403 ++++-- 2 files changed, 2517 insertions(+), 1067 deletions(-) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 509c021..008bbf4 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -1,9 +1,11 @@ -;;;; soap-client.el -- Access SOAP web services from Emacs +;;;; soap-client.el -- Access SOAP web services -*- lexical-binding: t -*- ;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Author: Alexandru Harsanyi +;; Author: Thomas Fitzsimmons ;; Created: December, 2009 +;; Version: 3.0.0 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; Homepage: http://code.google.com/p/emacs-soap-client @@ -43,10 +45,14 @@ (eval-when-compile (require 'cl)) (require 'xml) +(require 'xsd-regexp) +(require 'rng-xsd) +(require 'rng-dt) (require 'warnings) (require 'url) (require 'url-http) (require 'url-util) +(require 'url-vars) (require 'mm-decode) (defsubst soap-warning (message &rest args) @@ -74,13 +80,17 @@ soap-well-known-xmlns ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/") ("xsd" . "http://www.w3.org/2001/XMLSchema") ("xsi" . "http://www.w3.org/2001/XMLSchema-instance") + ("wsa" . "http://www.w3.org/2005/08/addressing") + ("wsaw" . "http://www.w3.org/2006/05/addressing/wsdl") ("soap" . "http://schemas.xmlsoap.org/soap/envelope/") ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/") ("http" . "http://schemas.xmlsoap.org/wsdl/http/") - ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/")) + ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/") + ("xml" . "http://www.w3.org/XML/1998/namespace")) "A list of well known xml namespaces and their aliases.") -(defvar soap-local-xmlns nil +(defvar soap-local-xmlns + '(("xml" . "http://www.w3.org/XML/1998/namespace")) "A list of local namespace aliases. This is a dynamically bound variable, controlled by `soap-with-local-xmlns'.") @@ -98,6 +108,10 @@ soap-target-xmlns dynamically bound variable, controlled by `soap-with-local-xmlns'") +(defvar soap-current-wsdl nil + "The current WSDL document used when decoding the SOAP response. +This is a dynamically bound variable.") + (defun soap-wk2l (well-known-name) "Return local variant of WELL-KNOWN-NAME. This is done by looking up the namespace in the @@ -106,24 +120,24 @@ soap-wk2l `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))) + well-known-name))) (cond - ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) - (let ((ns (match-string 1 wk-name-1)) - (name (match-string 2 wk-name-1))) - (let ((namespace (cdr (assoc ns soap-well-known-xmlns)))) - (cond ((equal namespace soap-default-xmlns) - ;; Name is unqualified in the default namespace - (if (symbolp well-known-name) - (intern name) - name)) - (t - (let* ((local-ns (car (rassoc namespace soap-local-xmlns))) - (local-name (concat local-ns ":" name))) - (if (symbolp well-known-name) - (intern local-name) - local-name))))))) - (t well-known-name)))) + ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) + (let ((ns (match-string 1 wk-name-1)) + (name (match-string 2 wk-name-1))) + (let ((namespace (cdr (assoc ns soap-well-known-xmlns)))) + (cond ((equal namespace soap-default-xmlns) + ;; Name is unqualified in the default namespace + (if (symbolp well-known-name) + (intern name) + name)) + (t + (let* ((local-ns (car (rassoc namespace soap-local-xmlns))) + (local-name (concat local-ns ":" name))) + (if (symbolp well-known-name) + (intern local-name) + local-name))))))) + (t well-known-name)))) (defun soap-l2wk (local-name) "Convert LOCAL-NAME into a well known name. @@ -134,40 +148,37 @@ soap-l2wk nil is returned if there is no well-known namespace for the namespace of LOCAL-NAME." (let ((l-name-1 (if (symbolp local-name) - (symbol-name local-name) - local-name)) + (symbol-name local-name) + local-name)) namespace name) (cond - ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) - (setq name (match-string 2 l-name-1)) - (let ((ns (match-string 1 l-name-1))) - (setq namespace (cdr (assoc ns soap-local-xmlns))) - (unless namespace - (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) - (t - (setq name l-name-1) - (setq namespace soap-default-xmlns))) + ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) + (setq name (match-string 2 l-name-1)) + (let ((ns (match-string 1 l-name-1))) + (setq namespace (cdr (assoc ns soap-local-xmlns))) + (unless namespace + (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) + (t + (setq name l-name-1) + (setq namespace soap-default-xmlns))) (if namespace (let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns)))) (if well-known-ns (let ((well-known-name (concat well-known-ns ":" name))) - (if (symbol-name local-name) + (if (symbolp local-name) (intern well-known-name) - well-known-name)) - (progn - ;; (soap-warning "soap-l2wk(%s): namespace %s has no well-known tag" - ;; local-name namespace) - nil))) - ;; if no namespace is defined, just return the unqualified name - name))) + well-known-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' @@ -178,19 +189,27 @@ soap-l2fq different namespace aliases for the same element." (let ((local-name-1 (if (symbolp local-name) (symbol-name local-name) - local-name))) + local-name))) (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1) (let ((ns (match-string 1 local-name-1)) (name (match-string 2 local-name-1))) (let ((namespace (cdr (assoc ns soap-local-xmlns)))) (if namespace (cons namespace name) - (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) + (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) (t (cons (if use-tns soap-target-xmlns - soap-default-xmlns) - local-name))))) + soap-default-xmlns) + local-name-1))))) + +(defun soap-name-p (name) + "Return true if NAME is a valid name for XMLSchema types. +A valid name is either a string or a cons of (NAMESPACE . NAME)." + (or (stringp name) + (and (consp name) + (stringp (car name)) + (stringp (cdr name))))) (defun soap-extract-xmlns (node &optional xmlns-table) "Return a namespace alias table for NODE by extending XMLNS-TABLE." @@ -211,16 +230,10 @@ soap-extract-xmlns ;; 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-extract-xmlns(%s): tns alias and targetNamespace mismatch" + (xml-node-name node)))) ((and tns (not target-ns)) - (setq target-ns (cdr tns))) - ((and (not tns) target-ns) - ;; a tns alias was not defined in this node. See if the node has - ;; a "targetNamespace" attribute and add an alias to this. Note - ;; that we might override an existing tns alias in XMLNS-TABLE, - ;; but that is intended. - (push (cons "tns" target-ns) xmlns)))) + (setq target-ns (cdr tns))))) (list default-ns target-ns (append xmlns xmlns-table)))) @@ -250,13 +263,21 @@ soap-xml-get-children1 (when (and (consp c) (soap-with-local-xmlns c ;; We use `ignore-errors' here because we want to silently - ;; skip nodes for which we cannot convert them to a - ;; well-known name. + ;; skip nodes when we cannot convert them to a well-known + ;; name. (eq (ignore-errors (soap-l2wk (xml-node-name c))) - child-name))) + child-name))) (push c result))) (nreverse result))) +(defun soap-xml-node-find-matching-child (node set) + "Return the first child of NODE whose name is a member of SET." + (catch 'found + (dolist (child (xml-node-children node)) + (when (and (consp child) + (memq (soap-l2wk (xml-node-name child)) set)) + (throw 'found child))))) + (defun soap-xml-get-attribute-or-nil1 (node attribute) "Return the NODE's ATTRIBUTE, or nil if it does not exist. This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can @@ -287,8 +308,13 @@ soap-element-fq-name "Return a fully qualified name for ELEMENT. A fq name is the concatenation of the namespace tag and the element name." - (concat (soap-element-namespace-tag element) - ":" (soap-element-name element))) + (cond ((soap-element-namespace-tag element) + (concat (soap-element-namespace-tag element) + ":" (soap-element-name element))) + ((soap-element-name element) + (soap-element-name element)) + (t + "*unnamed*"))) ;; a namespace link stores an alias for an object in once namespace to a ;; "target" object possibly in a different namespace @@ -311,11 +337,8 @@ soap-namespace-put (let ((name (soap-element-name element))) (push element (gethash name (soap-namespace-elements ns))))) -(defun soap-namespace-put-link (name target ns &optional replace) +(defun soap-namespace-put-link (name target ns) "Store a link from NAME to TARGET in NS. -An error will be signaled if an element by the same name is -already present in NS, unless REPLACE is non nil. - TARGET can be either a SOAP-ELEMENT or a string denoting an element name into another namespace. @@ -357,33 +380,1562 @@ soap-namespace-get ((= (length elements) 1) (car elements)) ((> (length elements) 1) (error - "Soap-namespace-get(%s): multiple elements, discriminant needed" - name)) + "Soap-namespace-get(%s): multiple elements, discriminant needed" + name)) (t nil)))) +;;;; XML Schema + +;; SOAP WSDL documents use XML Schema to define the types that are part of the +;; message exchange. We include here an XML schema model with a parser and +;; serializer/deserialiser. + +(defstruct (soap-xs-type (:include soap-element)) + id + attributes + attribute-groups) + +;;;;; soap-xs-basic-type + +(defstruct (soap-xs-basic-type (:include soap-xs-type)) + ;; Basic types are "built in" and we know how to handle them directly. + ;; Other type definitions reference basic types, so we need to create them + ;; in a namespace (see `soap-make-xs-basic-types') + + ;; a symbol of: string, dateTime, long, int, etc + kind + ) + +(defun soap-make-xs-basic-types (namespace-name &optional namespace-tag) + "Construct NAMESPACE-NAME containing the XMLSchema basic types. +An optional NAMESPACE-TAG can also be specified." + (let ((ns (make-soap-namespace :name namespace-name))) + (dolist (type '("string" "language" "ID" "IDREF" + "dateTime" "time" "date" "boolean" + "gYearMonth" "gYear" "gMonthDay" "gDay" "gMonth" + "long" "short" "int" "integer" "nonNegativeInteger" + "unsignedLong" "unsignedShort" "unsignedInt" + "decimal" "duration" + "byte" "unsignedByte" + "float" "double" + "base64Binary" "anyType" "anyURI" "QName" "Array" "byte[]")) + (soap-namespace-put + (make-soap-xs-basic-type :name type + :namespace-tag namespace-tag + :kind (intern type)) + ns)) + ns)) + +(defun soap-encode-xs-basic-type-attributes (value type) + "Encode the XML attributes for VALUE according to TYPE. +The xsi:type and an optional xsi:nil attributes are added. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-basic-type' objects." + (let ((xsi-type (soap-element-fq-name type)) + (basic-type (soap-xs-basic-type-kind type))) + ;; try to classify the type based on the value type and use that type when + ;; encoding + (when (eq basic-type 'anyType) + (cond ((stringp value) + (setq xsi-type "xsd:string" basic-type 'string)) + ((integerp value) + (setq xsi-type "xsd:int" basic-type 'int)) + ((memq value '(t nil)) + (setq xsi-type "xsd:boolean" basic-type 'boolean)) + (t + (error "Cannot classify anyType value")))) + + (insert " xsi:type=\"" xsi-type "\"") + ;; We have some ambiguity here, as a nil value represents "false" when the + ;; type is boolean, we will never have a "nil" boolean type... + (unless (or value (eq basic-type 'boolean)) + (insert " xsi:nil=\"true\"")))) + +(defun soap-encode-xs-basic-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-basic-type' objects." + (let ((kind (soap-xs-basic-type-kind type))) + + (when (eq kind 'anyType) + (cond ((stringp value) + (setq kind 'string)) + ((integerp value) + (setq kind 'int)) + ((memq value '(t nil)) + (setq kind 'boolean)) + (t + (error "Cannot classify anyType value")))) + + ;; NOTE: a nil value is not encoded, as an xsi:nil="true" attribute was + ;; encoded for it. However, we have some ambiguity here, as a nil value + ;; also represents "false" when the type is boolean... + + (when (or value (eq kind 'boolean)) + (let ((value-string + (case kind + ((string anyURI QName ID IDREF language) + (unless (stringp value) + (error "Not a string value: %s" value)) + (url-insert-entities-in-string value)) + ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth) + (cond ((consp value) + ;; Value is a (current-time) style value, + ;; convert to the ISO 8601-inspired XSD + ;; string format in UTC. + (format-time-string + (concat + (ecase kind + (dateTime "%Y-%m-%dT%H:%M:%S") + (time "%H:%M:%S") + (date "%Y-%m-%d") + (gYearMonth "%Y-%m") + (gYear "%Y") + (gMonthDay "--%m-%d") + (gDay "---%d") + (gMonth "--%m")) + ;; Internal time is always in UTC. + "Z") + value t)) + ((stringp value) + ;; Value is a string in the ISO 8601-inspired XSD + ;; format. Validate it. + (soap-decode-date-time value kind) + (url-insert-entities-in-string value)) + (t + (error "Invalid date-time format")))) + (boolean + (unless (memq value '(t nil)) + (error "Not a boolean value")) + (if value "true" "false")) + + ((long short int integer byte unsignedInt unsignedLong + unsignedShort nonNegativeInteger decimal duration) + (unless (integerp value) + (error "Not an integer value")) + (when (and (memq kind '(unsignedInt unsignedLong + unsignedShort + nonNegativeInteger)) + (< value 0)) + (error "Not a positive integer")) + (number-to-string value)) + + ((float double) + (unless (numberp value) + (error "Not a number")) + (number-to-string value)) + + (base64Binary + (unless (stringp value) + (error "Not a string value for base64Binary")) + (base64-encode-string value)) + + (otherwise + (error "Don't know how to encode %s for type %s" + value (soap-element-fq-name type)))))) + (soap-validate-xs-basic-type value-string type) + (insert value-string))))) + +;; Inspired by rng-xsd-convert-date-time. +(defun soap-decode-date-time (date-time-string datatype) + "Decode DATE-TIME-STRING as DATATYPE. +DATE-TIME-STRING should be in ISO 8601 basic or extended format. +DATATYPE is one of dateTime, time, date, gYearMonth, gYear, +gMonthDay, gDay or gMonth. + +Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR +SEC-FRACTION DATATYPE ZONE). This format is meant to be similar +to that returned by `decode-time' (and compatible with +`encode-time'). The differences are the DOW (day-of-week) field +is replaced with SEC-FRACTION, a float representing the +fractional seconds, and the DST (daylight savings time) field is +replaced with DATATYPE, a symbol representing the XSD primitive +datatype. This symbol can be used to determine which fields +apply and which don't when it's not already clear from context. +For example a datatype of 'time means the year, month and day +fields should be ignored. + +This function will throw an error if DATE-TIME-STRING represents +a leap second, since the XML Schema 1.1 standard explicitly +disallows them." + (let* ((datetime-regexp (cadr (get datatype 'rng-xsd-convert))) + (year-sign (progn + (string-match datetime-regexp date-time-string) + (match-string 1 date-time-string))) + (year (match-string 2 date-time-string)) + (month (match-string 3 date-time-string)) + (day (match-string 4 date-time-string)) + (hour (match-string 5 date-time-string)) + (minute (match-string 6 date-time-string)) + (second (match-string 7 date-time-string)) + (second-fraction (match-string 8 date-time-string)) + (has-time-zone (match-string 9 date-time-string)) + (time-zone-sign (match-string 10 date-time-string)) + (time-zone-hour (match-string 11 date-time-string)) + (time-zone-minute (match-string 12 date-time-string))) + (setq year-sign (if year-sign -1 1)) + (setq year + (if year + (* year-sign + (string-to-number year)) + ;; By defaulting to the epoch date, a time value can be treated as + ;; a relative number of seconds. + 1970)) + (setq month + (if month (string-to-number month) 1)) + (setq day + (if day (string-to-number day) 1)) + (setq hour + (if hour (string-to-number hour) 0)) + (setq minute + (if minute (string-to-number minute) 0)) + (setq second + (if second (string-to-number second) 0)) + (setq second-fraction + (if second-fraction + (float (string-to-number second-fraction)) + 0.0)) + (setq has-time-zone (and has-time-zone t)) + (setq time-zone-sign + (if (equal time-zone-sign "-") -1 1)) + (setq time-zone-hour + (if time-zone-hour (string-to-number time-zone-hour) 0)) + (setq time-zone-minute + (if time-zone-minute (string-to-number time-zone-minute) 0)) + (unless (and + ;; XSD does not allow year 0. + (> year 0) + (>= month 1) (<= month 12) + (>= day 1) (<= day (rng-xsd-days-in-month year month)) + (>= hour 0) (<= hour 23) + (>= minute 0) (<= minute 59) + ;; 60 represents a leap second, but leap seconds are explicitly + ;; disallowed by the XML Schema 1.1 specification. This agrees + ;; with typical Emacs installations, which don't count leap + ;; seconds in time values. + (>= second 0) (<= second 59) + (>= time-zone-hour 0) + (<= time-zone-hour 23) + (>= time-zone-minute 0) + (<= time-zone-minute 59)) + (error "Invalid or unsupported time: %s" date-time-string)) + ;; Return a value in a format similar to that returned by decode-time, and + ;; suitable for (apply 'encode-time ...). + (list second minute hour day month year second-fraction datatype + (if has-time-zone + (* (rng-xsd-time-to-seconds + time-zone-hour + time-zone-minute + 0) + time-zone-sign) + ;; UTC. + 0)))) + +(defun soap-decode-xs-basic-type (type node) + "Use TYPE, a `soap-xs-basic-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (let ((contents (xml-node-children node)) + (kind (soap-xs-basic-type-kind type)) + (attributes (xml-node-attributes node)) + (validate-type type) + (is-nil nil)) + + (dolist (attribute attributes) + (let ((attribute-type (soap-l2fq (car attribute))) + (attribute-value (cdr attribute))) + ;; xsi:type can override an element's expected type. + (when (equal attribute-type (soap-l2fq "xsi:type")) + (setq validate-type + (soap-wsdl-get attribute-value soap-current-wsdl))) + ;; xsi:nil can specify that an element is nil in which case we don't + ;; validate it. + (when (equal attribute-type (soap-l2fq "xsi:nil")) + (setq is-nil (string= (downcase attribute-value) "true"))))) + + (unless is-nil + ;; For validation purposes, when xml-node-children returns nil, treat it + ;; as the empty string. + (soap-validate-xs-basic-type (car (or contents (list ""))) validate-type)) + + (if (null contents) + nil + (ecase kind + ((string anyURI QName ID IDREF language) (car contents)) + ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth) + (car contents)) + ((long short int integer + unsignedInt unsignedLong unsignedShort nonNegativeInteger + decimal byte float double duration) + (string-to-number (car contents))) + (boolean (string= (downcase (car contents)) "true")) + (base64Binary (base64-decode-string (car contents))) + (anyType (soap-decode-any-type node)) + (Array (soap-decode-array node)))))) + +;; Register methods for `soap-xs-basic-type' +(let ((tag (aref (make-soap-xs-basic-type) 0))) + (put tag 'soap-attribute-encoder #'soap-encode-xs-basic-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-basic-type) + (put tag 'soap-decoder #'soap-decode-xs-basic-type)) + +;;;;; soap-xs-element + +(defstruct (soap-xs-element (:include soap-element)) + ;; NOTE: we don't support exact number of occurrences via minOccurs, + ;; maxOccurs. Instead we support optional? and multiple? + + id + type^ ; note: use soap-xs-element-type to retrieve this member + optional? + multiple? + reference + substitution-group + ;; contains a list of elements who point to this one via their + ;; substitution-group slot + alternatives + is-group) + +(defun soap-xs-element-type (element) + "Retrieve the type of ELEMENT. +This is normally stored in the TYPE^ slot, but if this element +contains a reference, we retrive the type of the reference." + (if (soap-xs-element-reference element) + (soap-xs-element-type (soap-xs-element-reference element)) + (soap-xs-element-type^ element))) + +(defun soap-node-optional (node) + "Return t if NODE specifies an optional element." + (or (equal (xml-get-attribute-or-nil node 'nillable) "true") + (let ((e (xml-get-attribute-or-nil node 'minOccurs))) + (and e (equal e "0"))))) + +(defun soap-node-multiple (node) + "Return t if NODE permits multiple elements." + (let* ((e (xml-get-attribute-or-nil node 'maxOccurs))) + (and e (not (equal e "1"))))) + +(defun soap-xs-parse-element (node) + "Construct a `soap-xs-element' from NODE." + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (type (xml-get-attribute-or-nil node 'type)) + (optional? (soap-node-optional node)) + (multiple? (soap-node-multiple node)) + (ref (xml-get-attribute-or-nil node 'ref)) + (substitution-group (xml-get-attribute-or-nil node 'substitutionGroup)) + (node-name (soap-l2wk (xml-node-name node)))) + (assert (memq node-name '(xsd:element xsd:group)) + "expecting xsd:element or xsd:group, got %s" node-name) + + (when type + (setq type (soap-l2fq type 'tns))) + + (when ref + (setq ref (soap-l2fq ref 'tns))) + + (when substitution-group + (setq substitution-group (soap-l2fq substitution-group 'tns))) + + (unless (or ref type) + ;; no type specified and this is not a reference. Must be a type + ;; defined within this node. + (let ((simple-type (soap-xml-get-children1 node 'xsd:simpleType))) + (if simple-type + (setq type (soap-xs-parse-simple-type (car simple-type))) + ;; else + (let ((complex-type (soap-xml-get-children1 node 'xsd:complexType))) + (if complex-type + (setq type (soap-xs-parse-complex-type (car complex-type))) + ;; else + (error "Soap-xs-parse-element: missing type or ref")))))) + + (make-soap-xs-element :name name + ;; Use the full namespace name for now, we will + ;; convert it to a nstag in + ;; `soap-resolve-references-for-xs-element' + :namespace-tag soap-target-xmlns + :id id :type^ type + :optional? optional? :multiple? multiple? + :reference ref + :substitution-group substitution-group + :is-group (eq node-name 'xsd:group)))) + +(defun soap-resolve-references-for-xs-element (element wsdl) + "Replace names in ELEMENT with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-element' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag element))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag element) nstag))))) + + (let ((type (soap-xs-element-type^ element))) + (cond ((soap-name-p type) + (setf (soap-xs-element-type^ element) + (soap-wsdl-get type wsdl 'soap-xs-type-p))) + ((soap-xs-type-p type) + ;; an inline defined type, this will not be reached from anywhere + ;; else, so we must resolve references now. + (soap-resolve-references type wsdl)))) + (let ((reference (soap-xs-element-reference element))) + (when (and (soap-name-p reference) + ;; xsd:group reference nodes will be converted to inline types + ;; by soap-resolve-references-for-xs-complex-type, so skip them + ;; here. + (not (soap-xs-element-is-group element))) + (setf (soap-xs-element-reference element) + (soap-wsdl-get reference wsdl 'soap-xs-element-p)))) + + (let ((subst (soap-xs-element-substitution-group element))) + (when (soap-name-p subst) + (let ((target (soap-wsdl-get subst wsdl))) + (if target + (push element (soap-xs-element-alternatives target)) + (soap-warning "No target found for substitution-group" subst)))))) + +(defun soap-encode-xs-element-attributes (value element) + "Encode the XML attributes for VALUE according to ELEMENT. +Currently no attributes are needed. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-basic-type' objects." + ;; Use the variables to suppress checkdoc and compiler warnings. + (list value element) + nil) + +(defun soap-should-encode-value-for-xs-element (value element) + "Return t if VALUE should be encoded for ELEMENT, nil otherwise." + (cond + ;; if value is not nil, attempt to encode it + (value) + + ;; value is nil, but the element's type is a boolean, so nil in this case + ;; means "false". We need to encode it. + ((let ((type (soap-xs-element-type element))) + (and (soap-xs-basic-type-p type) + (eq (soap-xs-basic-type-kind type) 'boolean)))) + + ;; This is not an optional element. Force encoding it (although this + ;; might fail at the validation step, but this is what we intend. + + ;; value is nil, but the element's type has some attributes which supply a + ;; default value. We need to encode it. + + ((let ((type (soap-xs-element-type element))) + (catch 'found + (dolist (a (soap-xs-type-attributes type)) + (when (soap-xs-attribute-default a) + (throw 'found t)))))) + + ;; otherwise, we don't need to encode it + (t nil))) + +(defun soap-type-is-array? (type) + "Return t if TYPE defines an ARRAY." + (and (soap-xs-complex-type-p type) + (eq (soap-xs-complex-type-indicator type) 'array))) + +(defvar soap-encoded-namespaces nil + "A list of namespace tags used during encoding a message. +This list is populated by `soap-encode-value' and used by +`soap-create-envelope' to add aliases for these namespace to the +XML request. + +This variable is dynamically bound in `soap-create-envelope'.") + +(defun soap-encode-xs-element (value element) + "Encode the VALUE according to ELEMENT. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-basic-type' objects." + (let ((fq-name (soap-element-fq-name element)) + (type (soap-xs-element-type element))) + ;; Only encode the element if it has a name. NOTE: soap-element-fq-name + ;; will return *unnamed* for such elements + (if (soap-element-name element) + ;; Don't encode this element if value is nil. However, even if value + ;; is nil we still want to encode this element if it has any attributes + ;; with default values. + (when (soap-should-encode-value-for-xs-element value element) + (progn + (insert "<" fq-name) + (soap-encode-attributes value type) + ;; If value is nil and type is boolean encode the value as "false". + ;; Otherwise don't encode the value. + (if (or value (and (soap-xs-basic-type-p type) + (eq (soap-xs-basic-type-kind type) 'boolean))) + (progn (insert ">") + ;; ARRAY's need special treatment, as each element of + ;; the array is encoded with the same tag as the + ;; current element... + (if (soap-type-is-array? type) + (let ((new-element (copy-soap-xs-element element))) + (when (soap-element-namespace-tag type) + (add-to-list 'soap-encoded-namespaces + (soap-element-namespace-tag type))) + (setf (soap-xs-element-type^ new-element) + (soap-xs-complex-type-base type)) + (loop for i below (length value) + do (progn + (soap-encode-xs-element (aref value i) new-element) + ))) + (soap-encode-value value type)) + (insert "\n")) + ;; else + (insert "/>\n")))) + (when (soap-should-encode-value-for-xs-element value element) + (soap-encode-value value type))))) + +(defun soap-decode-xs-element (element node) + "Use ELEMENT, a `soap-xs-element', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in ELEMENT. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (let ((type (soap-xs-element-type element))) + (soap-decode-type type node))) + +;; Register methods for `soap-xs-element' +(let ((tag (aref (make-soap-xs-element) 0))) + (put tag 'soap-resolve-references #'soap-resolve-references-for-xs-element) + (put tag 'soap-attribute-encoder #'soap-encode-xs-element-attributes) + (put tag 'soap-encoder #'soap-encode-xs-element) + (put tag 'soap-decoder #'soap-decode-xs-element)) + +;;;;; soap-xs-attribute + +(defstruct (soap-xs-attribute (:include soap-element)) + type ; a simple type or basic type + default ; the default value, if any + reference) + +(defstruct (soap-xs-attribute-group (:include soap-xs-type)) + reference) + +(defun soap-xs-parse-attribute (node) + "Construct a `soap-xs-attribute' from NODE." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:attribute) + "expecting xsd:attribute, got %s" (soap-l2wk (xml-node-name node))) + (let* ((name (xml-get-attribute-or-nil node 'name)) + (type (soap-l2fq (xml-get-attribute-or-nil node 'type))) + (default (xml-get-attribute-or-nil node 'fixed)) + (attribute (xml-get-attribute-or-nil node 'ref)) + (ref (when attribute (soap-l2fq attribute)))) + (unless (or type ref) + (setq type (soap-xs-parse-simple-type + (soap-xml-node-find-matching-child + node '(xsd:restriction xsd:list xsd:union))))) + (make-soap-xs-attribute + :name name :type type :default default :reference ref))) + +(defun soap-xs-parse-attribute-group (node) + "Construct a `soap-xs-attribute-group' from NODE." + (let ((node-name (soap-l2wk (xml-node-name node)))) + (assert (eq node-name 'xsd:attributeGroup) + "expecting xsd:attributeGroup, got %s" node-name) + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (ref (xml-get-attribute-or-nil node 'ref)) + attribute-group) + (when (and name ref) + (soap-warning "name and ref set for attribute group %s" node-name)) + (setq attribute-group + (make-soap-xs-attribute-group :id id + :name name + :reference (and ref (soap-l2fq ref)))) + (when (not ref) + (dolist (child (xml-node-children node)) + ;; Ignore whitespace. + (unless (stringp child) + ;; Ignore optional annotation. + ;; Ignore anyAttribute nodes. + (case (soap-l2wk (xml-node-name child)) + (xsd:attribute + (push (soap-xs-parse-attribute child) + (soap-xs-type-attributes attribute-group))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group child) + (soap-xs-attribute-group-attribute-groups + attribute-group))))))) + attribute-group))) + +(defun soap-resolve-references-for-xs-attribute (attribute wsdl) + "Replace names in ATTRIBUTE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-attribute' objects. + +See also `soap-wsdl-resolve-references'." + (let* ((type (soap-xs-attribute-type attribute)) + (reference (soap-xs-attribute-reference attribute)) + (predicate 'soap-xs-element-p) + (xml-reference + (and (soap-name-p reference) + (equal (car reference) "http://www.w3.org/XML/1998/namespace")))) + (cond (xml-reference + ;; Convert references to attributes defined by the XML + ;; schema (xml:base, xml:lang, xml:space and xml:id) to + ;; xsd:string, to avoid needing to bundle and parse + ;; xml.xsd. + (setq reference '("http://www.w3.org/2001/XMLSchema" . "string")) + (setq predicate 'soap-xs-basic-type-p)) + ((soap-name-p type) + (setf (soap-xs-attribute-type attribute) + (soap-wsdl-get type wsdl + (lambda (type) + (or (soap-xs-basic-type-p type) + (soap-xs-simple-type-p type)))))) + ((soap-xs-type-p type) + ;; an inline defined type, this will not be reached from anywhere + ;; else, so we must resolve references now. + (soap-resolve-references type wsdl))) + (when (soap-name-p reference) + (setf (soap-xs-attribute-reference attribute) + (soap-wsdl-get reference wsdl predicate))))) + +(put (aref (make-soap-xs-attribute) 0) + 'soap-resolve-references #'soap-resolve-references-for-xs-attribute) + +(defun soap-resolve-references-for-xs-attribute-group (attribute-group wsdl) + "Set slots in ATTRIBUTE-GROUP to the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-attribute-group' objects. + +See also `soap-wsdl-resolve-references'." + (let ((reference (soap-xs-attribute-group-reference attribute-group))) + (when (soap-name-p reference) + (let ((resolved (soap-wsdl-get reference wsdl + 'soap-xs-attribute-group-p))) + (dolist (attribute (soap-xs-attribute-group-attributes resolved)) + (soap-resolve-references attribute wsdl)) + (setf (soap-xs-attribute-group-name attribute-group) + (soap-xs-attribute-group-name resolved)) + (setf (soap-xs-attribute-group-id attribute-group) + (soap-xs-attribute-group-id resolved)) + (setf (soap-xs-attribute-group-reference attribute-group) nil) + (setf (soap-xs-attribute-group-attributes attribute-group) + (soap-xs-attribute-group-attributes resolved)) + (setf (soap-xs-attribute-group-attribute-groups attribute-group) + (soap-xs-attribute-group-attribute-groups resolved)))))) + +(put (aref (make-soap-xs-attribute-group) 0) + 'soap-resolve-references #'soap-resolve-references-for-xs-attribute-group) + +;;;;; soap-xs-simple-type + +(defstruct (soap-xs-simple-type (:include soap-xs-type)) + ;; A simple type is an extension on the basic type to which some + ;; restrictions can be added. For example we can define a simple type based + ;; off "string" with the restrictions that only the strings "one", "two" and + ;; "three" are valid values (this is an enumeration). + + base ; can be a single type, or a list of types for union types + enumeration ; nil, or list of permitted values for the type + pattern ; nil, or value must match this pattern + length-range ; a cons of (min . max) length, inclusive range. + ; For exact length, use (l, l). + ; nil means no range, + ; (nil . l) means no min range, + ; (l . nil) means no max range. + integer-range ; a pair of (min, max) integer values, inclusive range, + ; same meaning as `length-range' + is-list ; t if this is an xs:list, nil otherwise + ) + +(defun soap-xs-parse-simple-type (node) + "Construct an `soap-xs-simple-type' object from the XML NODE." + (assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:simpleType xsd:simpleContent)) + nil + "expecting xsd:simpleType or xsd:simpleContent node, got %s" + (soap-l2wk (xml-node-name node))) + + ;; NOTE: name can be nil for inline types. Such types cannot be added to a + ;; namespace. + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id))) + + (let ((type (make-soap-xs-simple-type + :name name :namespace-tag soap-target-xmlns :id id)) + (def (soap-xml-node-find-matching-child + node '(xsd:restriction xsd:extension xsd:union xsd:list)))) + (ecase (soap-l2wk (xml-node-name def)) + (xsd:restriction (soap-xs-add-restriction def type)) + (xsd:extension (soap-xs-add-extension def type)) + (xsd:union (soap-xs-add-union def type)) + (xsd:list (soap-xs-add-list def type))) + + type))) + +(defun soap-xs-add-restriction (node type) + "Add restrictions defined in XML NODE to TYPE, an `soap-xs-simple-type'." + + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction) + nil + "expecting xsd:restriction node, got %s" + (soap-l2wk (xml-node-name node))) + + (setf (soap-xs-simple-type-base type) + (soap-l2fq (xml-get-attribute node 'base))) + + (dolist (r (xml-node-children node)) + (unless (stringp r) ; skip the white space + (let ((value (xml-get-attribute r 'value))) + (case (soap-l2wk (xml-node-name r)) + (xsd:enumeration + (push value (soap-xs-simple-type-enumeration type))) + (xsd:pattern + (setf (soap-xs-simple-type-pattern type) + (concat "\\`" (xsdre-translate value) "\\'"))) + (xsd:length + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (cons value value)))) + (xsd:minLength + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (if (soap-xs-simple-type-length-range type) + (cons value + (cdr (soap-xs-simple-type-length-range type))) + ;; else + (cons value nil))))) + (xsd:maxLength + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (if (soap-xs-simple-type-length-range type) + (cons (car (soap-xs-simple-type-length-range type)) + value) + ;; else + (cons nil value))))) + (xsd:minExclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (1+ value) + (cdr (soap-xs-simple-type-integer-range type))) + ;; else + (cons (1+ value) nil))))) + (xsd:maxExclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (car (soap-xs-simple-type-integer-range type)) + (1- value)) + ;; else + (cons nil (1- value)))))) + (xsd:minInclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons value + (cdr (soap-xs-simple-type-integer-range type))) + ;; else + (cons value nil))))) + (xsd:maxInclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (car (soap-xs-simple-type-integer-range type)) + value) + ;; else + (cons nil value)))))))))) + +(defun soap-xs-add-union (node type) + "Add union members defined in XML NODE to TYPE, an `soap-xs-simple-type'." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:union) + nil + "expecting xsd:union node, got %s" (soap-l2wk (xml-node-name node))) + + (setf (soap-xs-simple-type-base type) + (mapcar 'soap-l2fq + (split-string + (or (xml-get-attribute-or-nil node 'memberTypes) "")))) + + ;; Additional simple types can be defined inside the union node. Add them + ;; to the base list. The "memberTypes" members will have to be resolved by + ;; the "resolve-references" method, the inline types will not. + (let (result) + (dolist (simple-type (soap-xml-get-children1 node 'xsd:simpleType)) + (push (soap-xs-parse-simple-type simple-type) result)) + (setf (soap-xs-simple-type-base type) + (append (soap-xs-simple-type-base type) (nreverse result))))) + +(defun soap-xs-add-list (node type) + "Add list defined in XML NODE to TYPE, a `soap-xs-simple-type'." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:list) + nil + "expecting xsd:list node, got %s" (soap-l2wk (xml-node-name node))) + + ;; A simple type can be defined inline inside the list node or referenced by + ;; the itemType attribute, in which case it will be resolved by the + ;; resolve-references method. + (let* ((item-type (xml-get-attribute-or-nil node 'itemType)) + (children (soap-xml-get-children1 node 'xsd:simpleType))) + (if item-type + (if (= (length children) 0) + (setf (soap-xs-simple-type-base type) (soap-l2fq item-type)) + (soap-warning + "xsd:list node with itemType has more than zero children: %s" + (soap-xs-type-name type))) + (if (= (length children) 1) + (setf (soap-xs-simple-type-base type) + (soap-xs-parse-simple-type + (car (soap-xml-get-children1 node 'xsd:simpleType)))) + (soap-warning "xsd:list node has more than one child %s" + (soap-xs-type-name type)))) + (setf (soap-xs-simple-type-is-list type) t))) + +(defun soap-xs-add-extension (node type) + "Add the extended type defined in XML NODE to TYPE, an `soap-xs-simple-type'." + (setf (soap-xs-simple-type-base type) + (soap-l2fq (xml-get-attribute node 'base))) + (dolist (attribute (soap-xml-get-children1 node 'xsd:attribute)) + (push (soap-xs-parse-attribute attribute) + (soap-xs-type-attributes type))) + (dolist (attribute-group (soap-xml-get-children1 node 'xsd:attributeGroup)) + (push (soap-xs-parse-attribute-group attribute-group) + (soap-xs-type-attribute-groups type)))) + +(defun soap-validate-xs-basic-type (value type) + "Validate VALUE against the basic type TYPE." + (let* ((kind (soap-xs-basic-type-kind type))) + (case kind + ((anyType Array byte[]) + value) + (t + (let ((convert (get kind 'rng-xsd-convert))) + (if convert + (if (rng-dt-make-value convert value) + value + (error "Invalid %s: %s" (symbol-name kind) value)) + (error "Don't know how to convert %s" kind))))))) + +(defun soap-validate-xs-simple-type (value type) + "Validate VALUE against the restrictions of TYPE." + + (let* ((base-type (soap-xs-simple-type-base type)) + (messages nil)) + (if (listp base-type) + (catch 'valid + (dolist (base base-type) + (condition-case error-object + (cond ((soap-xs-simple-type-p base) + (throw 'valid + (soap-validate-xs-simple-type value base))) + ((soap-xs-basic-type-p base) + (throw 'valid + (soap-validate-xs-basic-type value base)))) + (error (push (cadr error-object) messages)))) + (when messages + (error (mapconcat 'identity (nreverse messages) "; and: ")))) + (cl-flet ((fail-with-message (format value) + (push (format format value) messages) + (throw 'invalid nil))) + (catch 'invalid + (let ((enumeration (soap-xs-simple-type-enumeration type))) + (when (and (> (length enumeration) 1) + (not (member value enumeration))) + (fail-with-message "bad value, should be one of %s" enumeration))) + + (let ((pattern (soap-xs-simple-type-pattern type))) + (when (and pattern (not (string-match-p pattern value))) + (fail-with-message "bad value, should match pattern %s" pattern))) + + (let ((length-range (soap-xs-simple-type-length-range type))) + (when length-range + (unless (stringp value) + (fail-with-message + "bad value, should be a string with length range %s" + length-range)) + (when (car length-range) + (unless (>= (length value) (car length-range)) + (fail-with-message "short string, should be at least %s chars" + (car length-range)))) + (when (cdr length-range) + (unless (<= (length value) (cdr length-range)) + (fail-with-message "long string, should be at most %s chars" + (cdr length-range)))))) + + (let ((integer-range (soap-xs-simple-type-integer-range type))) + (when integer-range + (unless (numberp value) + (fail-with-message "bad value, should be a number with range %s" + integer-range)) + (when (car integer-range) + (unless (>= value (car integer-range)) + (fail-with-message "small value, should be at least %s" + (car integer-range)))) + (when (cdr integer-range) + (unless (<= value (cdr integer-range)) + (fail-with-message "big value, should be at most %s" + (cdr integer-range)))))))) + (when messages + (error "Xs-simple-type(%s, %s): %s" + value (or (soap-xs-type-name type) (soap-xs-type-id type)) + (car messages))))) + ;; Return the validated value. + value) + +(defun soap-resolve-references-for-xs-simple-type (type wsdl) + "Replace names in TYPE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-simple-type' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag type))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag type) nstag))))) + + (let ((base (soap-xs-simple-type-base type))) + (cond + ((soap-name-p base) + (setf (soap-xs-simple-type-base type) + (soap-wsdl-get base wsdl 'soap-xs-type-p))) + ((soap-xs-type-p base) + (soap-resolve-references base wsdl)) + ((listp base) + (setf (soap-xs-simple-type-base type) + (mapcar (lambda (type) + (cond ((soap-name-p type) + (soap-wsdl-get type wsdl 'soap-xs-type-p)) + ((soap-xs-type-p type) + (soap-resolve-references type wsdl) + type) + (t ; signal an error? + type))) + base))) + (t (error "Oops")))) + (dolist (attribute (soap-xs-type-attributes type)) + (soap-resolve-references attribute wsdl)) + (dolist (attribute-group (soap-xs-type-attribute-groups type)) + (soap-resolve-references attribute-group wsdl))) + +(defun soap-encode-xs-simple-type-attributes (value type) + "Encode the XML attributes for VALUE according to TYPE. +The xsi:type and an optional xsi:nil attributes are added. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-simple-type' objects." + (insert " xsi:type=\"" (soap-element-fq-name type) "\"") + (unless value (insert " xsi:nil=\"true\""))) + +(defun soap-encode-xs-simple-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-simple-type' objects." + (soap-validate-xs-simple-type value type) + (if (soap-xs-simple-type-is-list type) + (progn + (dolist (v (butlast value)) + (soap-encode-value v (soap-xs-simple-type-base type)) + (insert " ")) + (soap-encode-value (car (last value)) (soap-xs-simple-type-base type))) + (soap-encode-value value (soap-xs-simple-type-base type)))) + +(defun soap-decode-xs-simple-type (type node) + "Use TYPE, a `soap-xs-simple-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-simple-type' objects." + (if (soap-xs-simple-type-is-list type) + ;; Technically, we could construct fake XML NODEs and pass them to + ;; soap-decode-value... + (split-string (car (xml-node-children node))) + (let ((value (soap-decode-type (soap-xs-simple-type-base type) node))) + (soap-validate-xs-simple-type value type)))) + +;; Register methods for `soap-xs-simple-type' +(let ((tag (aref (make-soap-xs-simple-type) 0))) + (put tag 'soap-resolve-references + #'soap-resolve-references-for-xs-simple-type) + (put tag 'soap-attribute-encoder #'soap-encode-xs-simple-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-simple-type) + (put tag 'soap-decoder #'soap-decode-xs-simple-type)) + +;;;;; soap-xs-complex-type + +(defstruct (soap-xs-complex-type (:include soap-xs-type)) + indicator ; sequence, choice, all, array + base + elements + optional? + multiple? + is-group) + +(defun soap-xs-parse-complex-type (node) + "Construct a `soap-xs-complex-type' by parsing the XML NODE." + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (node-name (soap-l2wk (xml-node-name node))) + type + attributes + attribute-groups) + (assert (memq node-name '(xsd:complexType xsd:complexContent xsd:group)) + nil "unexpected node: %s" node-name) + + (dolist (def (xml-node-children node)) + (when (consp def) ; skip text nodes + (case (soap-l2wk (xml-node-name def)) + (xsd:attribute (push (soap-xs-parse-attribute def) attributes)) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) + attribute-groups)) + (xsd:simpleContent (setq type (soap-xs-parse-simple-type def))) + ((xsd:sequence xsd:all xsd:choice) + (setq type (soap-xs-parse-sequence def))) + (xsd:complexContent + (dolist (def (xml-node-children def)) + (when (consp def) + (case (soap-l2wk (xml-node-name def)) + (xsd:attribute + (push (soap-xs-parse-attribute def) attributes)) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) + attribute-groups)) + ((xsd:extension xsd:restriction) + (setq type + (soap-xs-parse-extension-or-restriction def))) + ((xsd:sequence xsd:all xsd:choice) + (soap-xs-parse-sequence def))))))))) + (unless type + ;; the type has not been built, this is a shortcut for a simpleContent + ;; node + (setq type (make-soap-xs-complex-type))) + + (setf (soap-xs-type-name type) name) + (setf (soap-xs-type-namespace-tag type) soap-target-xmlns) + (setf (soap-xs-type-id type) id) + (setf (soap-xs-type-attributes type) + (append attributes (soap-xs-type-attributes type))) + (setf (soap-xs-type-attribute-groups type) + (append attribute-groups (soap-xs-type-attribute-groups type))) + (when (soap-xs-complex-type-p type) + (setf (soap-xs-complex-type-is-group type) + (eq node-name 'xsd:group))) + type)) + +(defun soap-xs-parse-sequence (node) + "Parse a sequence definition from XML NODE. +Returns a `soap-xs-complex-type'" + (assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:sequence xsd:choice xsd:all)) + nil + "unexpected node: %s" (soap-l2wk (xml-node-name node))) + + (let ((type (make-soap-xs-complex-type))) + + (setf (soap-xs-complex-type-indicator type) + (ecase (soap-l2wk (xml-node-name node)) + (xsd:sequence 'sequence) + (xsd:all 'all) + (xsd:choice 'choice))) + + (setf (soap-xs-complex-type-optional? type) (soap-node-optional node)) + (setf (soap-xs-complex-type-multiple? type) (soap-node-multiple node)) + + (dolist (r (xml-node-children node)) + (unless (stringp r) ; skip the white space + (case (soap-l2wk (xml-node-name r)) + ((xsd:element xsd:group) + (push (soap-xs-parse-element r) + (soap-xs-complex-type-elements type))) + ((xsd:sequence xsd:choice xsd:all) + ;; an inline sequence, choice or all node + (let ((choice (soap-xs-parse-sequence r))) + (push (make-soap-xs-element :name nil :type^ choice) + (soap-xs-complex-type-elements type)))) + (xsd:attribute + (push (soap-xs-parse-attribute r) + (soap-xs-type-attributes type))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group r) + (soap-xs-type-attribute-groups type)))))) + + (setf (soap-xs-complex-type-elements type) + (nreverse (soap-xs-complex-type-elements type))) + + type)) + +(defun soap-xs-parse-extension-or-restriction (node) + "Parse an extension or restriction definition from XML NODE. +Return a `soap-xs-complex-type'." + (assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:extension xsd:restriction)) + nil + "unexpected node: %s" (soap-l2wk (xml-node-name node))) + (let (type + attributes + attribute-groups + array? + (base (xml-get-attribute-or-nil node 'base))) + + ;; Array declarations are recognized specially, it is unclear to me how + ;; they could be treated generally... + (setq array? + (and (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction) + (equal base (soap-wk2l "soapenc:Array")))) + + (dolist (def (xml-node-children node)) + (when (consp def) ; skip text nodes + (case (soap-l2wk (xml-node-name def)) + ((xsd:sequence xsd:choice xsd:all) + (setq type (soap-xs-parse-sequence def))) + (xsd:attribute + (if array? + (let ((array-type + (soap-xml-get-attribute-or-nil1 def 'wsdl:arrayType))) + (when (and array-type + (string-match "^\\(.*\\)\\[\\]$" array-type)) + ;; Override + (setq base (match-string 1 array-type)))) + ;; else + (push (soap-xs-parse-attribute def) attributes))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) attribute-groups))))) + + (unless type + (setq type (make-soap-xs-complex-type)) + (when array? + (setf (soap-xs-complex-type-indicator type) 'array))) + + (setf (soap-xs-complex-type-base type) (soap-l2fq base)) + (setf (soap-xs-complex-type-attributes type) attributes) + (setf (soap-xs-complex-type-attribute-groups type) attribute-groups) + type)) + +(defun soap-resolve-references-for-xs-complex-type (type wsdl) + "Replace names in TYPE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-complex-type' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag type))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag type) nstag))))) + + (let ((base (soap-xs-complex-type-base type))) + (cond ((soap-name-p base) + (setf (soap-xs-complex-type-base type) + (soap-wsdl-get base wsdl 'soap-xs-type-p))) + ((soap-xs-type-p base) + (soap-resolve-references base wsdl)))) + (let (all-elements) + (dolist (element (soap-xs-complex-type-elements type)) + (if (soap-xs-element-is-group element) + ;; This is an xsd:group element that references an xsd:group node, + ;; which we treat as a complex type. We replace the reference + ;; element by inlining the elements of the referenced xsd:group + ;; (complex type) node. + (let ((type (soap-wsdl-get + (soap-xs-element-reference element) + wsdl (lambda (type) + (and + (soap-xs-complex-type-p type) + (soap-xs-complex-type-is-group type)))))) + (dolist (element (soap-xs-complex-type-elements type)) + (soap-resolve-references element wsdl) + (push element all-elements))) + ;; This is a non-xsd:group node so just add it directly. + (soap-resolve-references element wsdl) + (push element all-elements))) + (setf (soap-xs-complex-type-elements type) (nreverse all-elements))) + (dolist (attribute (soap-xs-type-attributes type)) + (soap-resolve-references attribute wsdl)) + (dolist (attribute-group (soap-xs-type-attribute-groups type)) + (soap-resolve-references attribute-group wsdl))) + +(defun soap-encode-xs-complex-type-attributes (value type) + "Encode the XML attributes for encoding VALUE according to TYPE. +The xsi:type and optional xsi:nil attributes are added, plus +additional attributes needed for arrays types, if applicable. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-complex-type' objects." + (if (eq (soap-xs-complex-type-indicator type) 'array) + (let ((element-type (soap-xs-complex-type-base type))) + (insert " xsi:type=\"soapenc:Array\"") + (insert " soapenc:arrayType=\"" + (soap-element-fq-name element-type) + "[" (format "%s" (length value)) "]" "\"")) + ;; else + (progn + (dolist (a (soap-get-xs-attributes type)) + (let ((element-name (soap-element-name a))) + (if (soap-xs-attribute-default a) + (insert " " element-name + "=\"" (soap-xs-attribute-default a) "\"") + (dolist (value-pair value) + (when (equal element-name (symbol-name (car value-pair))) + (insert " " element-name + "=\"" (cdr value-pair) "\"")))))) + ;; If this is not an empty type, and we have no value, mark it as nil + (when (and (soap-xs-complex-type-indicator type) (null value)) + (insert " xsi:nil=\"true\""))))) + +(defun soap-get-candidate-elements (element) + "Return a list of elements that are compatible with ELEMENT. +The returned list includes ELEMENT's references and +alternatives." + (let ((reference (soap-xs-element-reference element))) + ;; If the element is a reference, append the reference and its + ;; alternatives... + (if reference + (append (list reference) + (soap-xs-element-alternatives reference)) + ;; ...otherwise append the element itself and its alternatives. + (append (list element) + (soap-xs-element-alternatives element))))) + +(defun soap-encode-xs-complex-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-complex-type' objects." + (case (soap-xs-complex-type-indicator type) + (array + (error "soap-encode-xs-complex-type arrays are handled elsewhere")) + ((sequence choice all nil) + (let ((type-list (list type))) + + ;; Collect all base types + (let ((base (soap-xs-complex-type-base type))) + (while base + (push base type-list) + (setq base (soap-xs-complex-type-base base)))) + + (dolist (type type-list) + (dolist (element (soap-xs-complex-type-elements type)) + (catch 'done + (let ((instance-count 0)) + (dolist (candidate (soap-get-candidate-elements element)) + (let ((e-name (soap-xs-element-name candidate))) + (if e-name + (let ((e-name (intern e-name))) + (dolist (v value) + (when (equal (car v) e-name) + (incf instance-count) + (soap-encode-value (cdr v) candidate)))) + (if (soap-xs-complex-type-indicator type) + (let ((current-point (point))) + ;; Check if encoding happened by checking if + ;; characters were inserted in the buffer. + (soap-encode-value value candidate) + (when (not (equal current-point (point))) + (incf instance-count))) + (dolist (v value) + (let ((current-point (point))) + (soap-encode-value v candidate) + (when (not (equal current-point (point))) + (incf instance-count)))))))) + ;; Do some sanity checking + (let* ((indicator (soap-xs-complex-type-indicator type)) + (element-type (soap-xs-element-type element)) + (reference (soap-xs-element-reference element)) + (e-name (or (soap-xs-element-name element) + (and reference + (soap-xs-element-name reference))))) + (cond ((and (eq indicator 'choice) + (> instance-count 0)) + ;; This was a choice node and we encoded + ;; one instance. + (throw 'done t)) + ((and (not (eq indicator 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning + "While encoding %s: missing non-nillable slot %s" + value e-name)) + ((and (> instance-count 1) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning + (concat "While encoding %s: expected single," + " found multiple elements for slot %s") + value e-name)))))))))) + (t + (error "Don't know how to encode complex type: %s" + (soap-xs-complex-type-indicator type))))) + +(defun soap-xml-get-children-fq (node child-name) + "Return the children of NODE named CHILD-NAME. +This is the same as `xml-get-children1', but NODE's local +namespace is used to resolve the children's namespace tags." + (let (result) + (dolist (c (xml-node-children node)) + (when (and (consp c) + (soap-with-local-xmlns node + ;; We use `ignore-errors' here because we want to silently + ;; skip nodes for which we cannot convert them to a + ;; well-known name. + (equal (ignore-errors + (soap-l2fq (xml-node-name c))) + child-name))) + (push c result))) + (nreverse result))) + +(defun soap-xs-element-get-fq-name (element wsdl) + "Return ELEMENT's fully-qualified name using WSDL's alias table. +Return nil if ELEMENT does not have a name." + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc + (soap-element-namespace-tag element) + ns-aliases)))) + (when ns-name + (cons ns-name (soap-element-name element))))) + +(defun soap-xs-complex-type-optional-p (type) + "Return t if TYPE or any of TYPE's ancestor types is optional. +Return nil otherwise." + (when type + (or (soap-xs-complex-type-optional? type) + (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-optional-p + (soap-xs-complex-type-base type)))))) + +(defun soap-xs-complex-type-multiple-p (type) + "Return t if TYPE or any of TYPE's ancestor types permits multiple elements. +Return nil otherwise." + (when type + (or (soap-xs-complex-type-multiple? type) + (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-multiple-p + (soap-xs-complex-type-base type)))))) + +(defun soap-get-xs-attributes-from-groups (attribute-groups) + "Return a list of attributes from all ATTRIBUTE-GROUPS." + (let (attributes) + (dolist (group attribute-groups) + (let ((sub-groups (soap-xs-attribute-group-attribute-groups group))) + (setq attributes (append attributes + (soap-get-xs-attributes-from-groups sub-groups) + (soap-xs-attribute-group-attributes group))))) + attributes)) + +(defun soap-get-xs-attributes (type) + "Return a list of all of TYPE's and TYPE's ancestors' attributes." + (let* ((base (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-base type))) + (attributes (append (soap-xs-type-attributes type) + (soap-get-xs-attributes-from-groups + (soap-xs-type-attribute-groups type))))) + (if base + (append attributes (soap-get-xs-attributes base)) + attributes))) + +(defun soap-decode-xs-attributes (type node) + "Use TYPE, a `soap-xs-complex-type', to decode the attributes of NODE." + (let (result) + (dolist (attribute (soap-get-xs-attributes type)) + (let* ((name (soap-xs-attribute-name attribute)) + (attribute-type (soap-xs-attribute-type attribute)) + (symbol (intern name)) + (value (xml-get-attribute-or-nil node symbol))) + ;; We don't support attribute uses: required, optional, prohibited. + (cond + ((soap-xs-basic-type-p attribute-type) + ;; Basic type values are validated by xml.el. + (when value + (push (cons symbol + ;; Create a fake XML node to satisfy the + ;; soap-decode-xs-basic-type API. + (soap-decode-xs-basic-type attribute-type + (list symbol nil value))) + result))) + ((soap-xs-simple-type-p attribute-type) + (when value + (push (cons symbol + (soap-validate-xs-simple-type value attribute-type)) + result))) + (t + (error (concat "Attribute %s is of type %s which is" + " not a basic or simple type") + name (soap-name-p attribute)))))) + result)) + +(defun soap-decode-xs-complex-type (type node) + "Use TYPE, a `soap-xs-complex-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (case (soap-xs-complex-type-indicator type) + (array + (let ((result nil) + (element-type (soap-xs-complex-type-base type))) + (dolist (node (xml-node-children node)) + (when (consp node) + (push (soap-decode-type element-type node) result))) + (nreverse result))) + ((sequence choice all nil) + (let ((result nil) + (base (soap-xs-complex-type-base type))) + (when base + (setq result (nreverse (soap-decode-type base node)))) + (catch 'done + (dolist (element (soap-xs-complex-type-elements type)) + (let* ((instance-count 0) + (e-name (soap-xs-element-name element)) + ;; Heuristic: guess if we need to decode using local + ;; namespaces. + (use-fq-names (string-match ":" (symbol-name (car node)))) + (children (if e-name + (if use-fq-names + ;; Find relevant children + ;; using local namespaces by + ;; searching for the element's + ;; fully-qualified name. + (soap-xml-get-children-fq + node + (soap-xs-element-get-fq-name + element soap-current-wsdl)) + ;; No local namespace resolution + ;; needed so use the element's + ;; name unqualified. + (xml-get-children node (intern e-name))) + ;; e-name is nil so a) we don't know which + ;; children to operate on, and b) we want to + ;; re-use soap-decode-xs-complex-type, which + ;; expects a node argument with a complex + ;; type; therefore we need to operate on the + ;; entire node. We wrap node in a list so + ;; that it will carry through as "node" in the + ;; loop below. + ;; + ;; For example: + ;; + ;; Element Type: + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; Node: + ;; + ;; + ;; 1 + ;; + ;; + ;; soap-decode-type will be called below with: + ;; + ;; element = + ;; + ;; + ;; + ;; + ;; node = + ;; + ;; + ;; 1 + ;; + (list node))) + (element-type (soap-xs-element-type element))) + (dolist (node children) + (incf instance-count) + (let* ((attributes + (soap-decode-xs-attributes element-type node)) + ;; Attributes may specify xsi:type override. + (element-type + (if (soap-xml-get-attribute-or-nil1 node 'xsi:type) + (soap-wsdl-get + (soap-l2fq + (soap-xml-get-attribute-or-nil1 node + 'xsi:type)) + soap-current-wsdl 'soap-xs-type-p t) + element-type)) + (decoded-child (soap-decode-type element-type node))) + (if e-name + (push (cons (intern e-name) + (append attributes decoded-child)) result) + ;; When e-name is nil we don't want to introduce an extra + ;; level of nesting, so we splice the decoding into + ;; result. + (setq result (append decoded-child result))))) + (cond ((and (eq (soap-xs-complex-type-indicator type) 'choice) + ;; Choices can allow multiple values. + (not (soap-xs-complex-type-multiple-p type)) + (> instance-count 0)) + ;; This was a choice node, and we decoded one value. + (throw 'done t)) + + ;; Do some sanity checking + ((and (not (eq (soap-xs-complex-type-indicator type) + 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning "missing non-nillable slot %s" e-name)) + ((and (> instance-count 1) + (not (soap-xs-complex-type-multiple-p type)) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning "expected single %s slot, found multiple" + e-name)))))) + (nreverse result))) + (t + (error "Don't know how to decode complex type: %s" + (soap-xs-complex-type-indicator type))))) + +;; Register methods for `soap-xs-complex-type' +(let ((tag (aref (make-soap-xs-complex-type) 0))) + (put tag 'soap-resolve-references + #'soap-resolve-references-for-xs-complex-type) + (put tag 'soap-attribute-encoder #'soap-encode-xs-complex-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-complex-type) + (put tag 'soap-decoder #'soap-decode-xs-complex-type)) + ;;;; WSDL documents ;;;;; WSDL document elements -(defstruct (soap-basic-type (:include soap-element)) - 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-SEQUENCE-ELEMENT - ) - -(defstruct (soap-array-type (:include soap-element)) - element-type ; WSDL-TYPE of the array elements - ) (defstruct (soap-message (:include soap-element)) parts ; ALIST of NAME => WSDL-TYPE name @@ -393,7 +1945,9 @@ soap-sequence-element parameter-order input ; (NAME . MESSAGE) output ; (NAME . MESSAGE) - faults) ; a list of (NAME . MESSAGE) + faults ; a list of (NAME . MESSAGE) + input-action ; WS-addressing action string + output-action) ; WS-addressing action string (defstruct (soap-port-type (:include soap-element)) operations) ; a namespace of operations @@ -404,8 +1958,10 @@ soap-sequence-element (defstruct soap-bound-operation operation ; SOAP-OPERATION soap-action ; value for SOAPAction HTTP header + soap-headers ; list of (message part use) + soap-body ; message parts present in the body use ; 'literal or 'encoded, see - ; http://www.w3.org/TR/wsdl#_soap:body + ; http://www.w3.org/TR/wsdl#_soap:body ) (defstruct (soap-binding (:include soap-element)) @@ -416,49 +1972,49 @@ soap-bound-operation service-url binding) -(defun soap-default-xsd-types () - "Return a namespace containing some of the XMLSchema types." - (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema"))) - (dolist (type '("string" "dateTime" "boolean" - "long" "int" "integer" "unsignedInt" "byte" "float" "double" - "base64Binary" "anyType" "anyURI" "Array" "byte[]")) - (soap-namespace-put - (make-soap-basic-type :name type :kind (intern type)) - ns)) - ns)) - -(defun soap-default-soapenc-types () - "Return a namespace containing some of the SOAPEnc types." - (let ((ns (make-soap-namespace - :name "http://schemas.xmlsoap.org/soap/encoding/"))) - (dolist (type '("string" "dateTime" "boolean" - "long" "int" "integer" "unsignedInt" "byte" "float" "double" - "base64Binary" "anyType" "anyURI" "Array" "byte[]")) - (soap-namespace-put - (make-soap-basic-type :name type :kind (intern type)) - ns)) - ns)) - -(defun soap-type-p (element) - "Return t if ELEMENT is a SOAP data type (basic or complex)." - (or (soap-basic-type-p element) - (soap-sequence-type-p element) - (soap-array-type-p element))) - ;;;;; The WSDL document ;; The WSDL data structure used for encoding/decoding SOAP messages -(defstruct soap-wsdl +(defstruct (soap-wsdl + ;; NOTE: don't call this constructor, see `soap-make-wsdl' + (:constructor soap-make-wsdl^) + (:copier soap-copy-wsdl)) origin ; file or URL from which this wsdl was loaded + current-file ; most-recently fetched file or URL + xmlschema-imports ; a list of schema imports ports ; a list of SOAP-PORT instances alias-table ; a list of namespace aliases namespaces ; a list of namespaces ) +(defun soap-make-wsdl (origin) + "Create a new WSDL document, loaded from ORIGIN, and intialize it." + (let ((wsdl (soap-make-wsdl^ :origin origin))) + + ;; Add the XSD types to the wsdl document + (let ((ns (soap-make-xs-basic-types + "http://www.w3.org/2001/XMLSchema" "xsd"))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl)) + + ;; Add the soapenc types to the wsdl document + (let ((ns (soap-make-xs-basic-types + "http://schemas.xmlsoap.org/soap/encoding/" "soapenc"))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl)) + + wsdl)) + (defun soap-wsdl-add-alias (alias name wsdl) "Add a namespace ALIAS for NAME to the WSDL document." - (push (cons alias name) (soap-wsdl-alias-table wsdl))) + (let ((existing (assoc alias (soap-wsdl-alias-table wsdl)))) + (if existing + (unless (equal (cdr existing) name) + (warn "Redefining alias %s from %s to %s" + alias (cdr existing) name) + (push (cons alias name) (soap-wsdl-alias-table wsdl))) + (push (cons alias name) (soap-wsdl-alias-table wsdl))))) (defun soap-wsdl-find-namespace (name wsdl) "Find a namespace by NAME in the WSDL document." @@ -474,11 +2030,11 @@ soap-wsdl-add-namespace (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl))) (if existing ;; Add elements from NS to EXISTING, replacing existing values. - (maphash (lambda (key value) + (maphash (lambda (_key value) (dolist (v value) (soap-namespace-put v existing))) (soap-namespace-elements ns)) - (push ns (soap-wsdl-namespaces wsdl))))) + (push ns (soap-wsdl-namespaces wsdl))))) (defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table) "Retrieve element NAME from the WSDL document. @@ -517,13 +2073,13 @@ soap-wsdl-get (ns-name (cdr (assoc ns-alias alias-table)))) (unless ns-name (error "Soap-wsdl-get(%s): cannot find namespace alias %s" - name ns-alias)) + 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)))) + "Soap-wsdl-get(%s): unknown namespace %s, referenced as %s" + name ns-name ns-alias)))) (t (error "Soap-wsdl-get(%s): bad name" name))) @@ -533,7 +2089,7 @@ soap-wsdl-get (lambda (e) (or (funcall 'soap-namespace-link-p e) (funcall predicate e))) - nil))) + nil))) (unless element (error "Soap-wsdl-get(%s): cannot find element" name)) @@ -541,92 +2097,96 @@ soap-wsdl-get (if (soap-namespace-link-p element) ;; NOTE: don't use the local alias table here (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate) - element))) + element))) + +;;;;; soap-parse-schema + +(defun soap-parse-schema (node wsdl) + "Parse a schema NODE, placing the results in WSDL. +Return a SOAP-NAMESPACE containing the elements." + (soap-with-local-xmlns node + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + nil + "expecting an xsd:schema node, got %s" + (soap-l2wk (xml-node-name node))) + + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + + (dolist (def (xml-node-children node)) + (unless (stringp def) ; skip text nodes + (case (soap-l2wk (xml-node-name def)) + (xsd:import + ;; Imports will be processed later + ;; NOTE: we should expand the location now! + (let ((location (or + (xml-get-attribute-or-nil def 'schemaLocation) + (xml-get-attribute-or-nil def 'location)))) + (when location + (push location (soap-wsdl-xmlschema-imports wsdl))))) + (xsd:element + (soap-namespace-put (soap-xs-parse-element def) ns)) + (xsd:attribute + (soap-namespace-put (soap-xs-parse-attribute def) ns)) + (xsd:attributeGroup + (soap-namespace-put (soap-xs-parse-attribute-group def) ns)) + (xsd:simpleType + (soap-namespace-put (soap-xs-parse-simple-type def) ns)) + ((xsd:complexType xsd:group) + (soap-namespace-put (soap-xs-parse-complex-type def) ns))))) + ns))) ;;;;; Resolving references for wsdl types ;; See `soap-wsdl-resolve-references', which is the main entry point for ;; resolving references -(defun soap-resolve-references-for-element (element wsdl) - "Resolve references in ELEMENT using the WSDL document. -This is a generic function which invokes a specific function -depending on the element type. +(defun soap-resolve-references (element wsdl) + "Replace names in ELEMENT with the referenced objects in the WSDL. +This is a generic function which invokes a specific resolver +function depending on the type of the ELEMENT. -If ELEMENT has no resolver function, it is silently ignored. - -All references are resolved in-place, that is the ELEMENT is -updated." +If ELEMENT has no resolver function, it is silently ignored." (let ((resolver (get (aref element 0) 'soap-resolve-references))) (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 -`soap-wsdl-resolve-references'" - (let ((parent (soap-sequence-type-parent type))) - (when (or (consp parent) (stringp parent)) - (setf (soap-sequence-type-parent type) - (soap-wsdl-get - parent wsdl - ;; 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 - ;; 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 - ;; references in it, because it might not be reached by - ;; scanning the wsdl names. - (soap-resolve-references-for-element element-type wsdl)))))) - -(defun soap-resolve-references-for-array-type (type wsdl) - "Resolve references for an array TYPE using WSDL. -See also `soap-resolve-references-for-element' and -`soap-wsdl-resolve-references'" - (let ((element-type (soap-array-type-element-type type))) - (when (or (consp element-type) (stringp element-type)) - (setf (soap-array-type-element-type type) - (soap-wsdl-get - element-type wsdl - ;; 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. -See also `soap-resolve-references-for-element' and -`soap-wsdl-resolve-references'" + "Replace names in MESSAGE with the referenced objects in the WSDL. +This is a generic function, called by `soap-resolve-references', +you should use that function instead. + +See also `soap-wsdl-resolve-references'." (let (resolved-parts) (dolist (part (soap-message-parts message)) (let ((name (car part)) - (type (cdr part))) + (element (cdr part))) (when (stringp name) (setq name (intern name))) - (when (or (consp type) (stringp type)) - (setq type (soap-wsdl-get type wsdl 'soap-type-p))) - (push (cons name type) resolved-parts))) - (setf (soap-message-parts message) (nreverse resolved-parts)))) + (if (soap-name-p element) + (setq element (soap-wsdl-get + element wsdl + (lambda (x) + (or (soap-xs-type-p x) (soap-xs-element-p x))))) + ;; else, inline element, resolve recursively, as the element + ;; won't be reached. + (soap-resolve-references element wsdl) + (unless (soap-element-namespace-tag element) + (setf (soap-element-namespace-tag element) + (soap-element-namespace-tag message)))) + (push (cons name element) resolved-parts))) + (setf (soap-message-parts message) (nreverse resolved-parts)))) (defun soap-resolve-references-for-operation (operation wsdl) "Resolve references for an OPERATION type using the WSDL document. -See also `soap-resolve-references-for-element' and +See also `soap-resolve-references' and `soap-wsdl-resolve-references'" + + (let ((namespace (soap-element-namespace-tag operation))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag operation) nstag))))) + (let ((input (soap-operation-input operation)) (counter 0)) (let ((name (car input)) @@ -634,10 +2194,10 @@ soap-resolve-references-for-operation ;; Name this part if it was not named (when (or (null name) (equal name "")) (setq name (format "in%d" (incf counter)))) - (when (or (consp message) (stringp message)) + (when (soap-name-p message) (setf (soap-operation-input operation) (cons (intern name) - (soap-wsdl-get message wsdl 'soap-message-p)))))) + (soap-wsdl-get message wsdl 'soap-message-p)))))) (let ((output (soap-operation-output operation)) (counter 0)) @@ -645,10 +2205,10 @@ soap-resolve-references-for-operation (message (cdr output))) (when (or (null name) (equal name "")) (setq name (format "out%d" (incf counter)))) - (when (or (consp message) (stringp message)) + (when (soap-name-p message) (setf (soap-operation-output operation) (cons (intern name) - (soap-wsdl-get message wsdl 'soap-message-p)))))) + (soap-wsdl-get message wsdl 'soap-message-p)))))) (let ((resolved-faults nil) (counter 0)) @@ -657,11 +2217,11 @@ soap-resolve-references-for-operation (message (cdr fault))) (when (or (null name) (equal name "")) (setq name (format "fault%d" (incf counter)))) - (if (or (consp message) (stringp message)) + (if (soap-name-p message) (push (cons (intern name) - (soap-wsdl-get message wsdl 'soap-message-p)) + (soap-wsdl-get message wsdl 'soap-message-p)) resolved-faults) - (push fault resolved-faults)))) + (push fault resolved-faults)))) (setf (soap-operation-faults operation) resolved-faults)) (when (= (length (soap-operation-parameter-order operation)) 0) @@ -673,42 +2233,44 @@ soap-resolve-references-for-operation (mapcar (lambda (p) (if (stringp p) (intern p) - p)) + p)) (soap-operation-parameter-order operation)))) (defun soap-resolve-references-for-binding (binding wsdl) - "Resolve references for a BINDING type using the WSDL document. -See also `soap-resolve-references-for-element' and + "Resolve references for a BINDING type using the WSDL document. +See also `soap-resolve-references' and `soap-wsdl-resolve-references'" - (when (or (consp (soap-binding-port-type binding)) - (stringp (soap-binding-port-type binding))) + (when (soap-name-p (soap-binding-port-type binding)) (setf (soap-binding-port-type binding) (soap-wsdl-get (soap-binding-port-type binding) - wsdl 'soap-port-type-p))) + wsdl 'soap-port-type-p))) (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding)))) (maphash (lambda (k v) (setf (soap-bound-operation-operation v) - (soap-namespace-get k port-ops 'soap-operation-p))) + (soap-namespace-get k port-ops 'soap-operation-p)) + (let (resolved-headers) + (dolist (h (soap-bound-operation-soap-headers v)) + (push (list (soap-wsdl-get (nth 0 h) wsdl) + (intern (nth 1 h)) + (nth 2 h)) + resolved-headers)) + (setf (soap-bound-operation-soap-headers v) + (nreverse resolved-headers)))) (soap-binding-operations binding)))) (defun soap-resolve-references-for-port (port wsdl) - "Resolve references for a PORT type using the WSDL document. -See also `soap-resolve-references-for-element' and -`soap-wsdl-resolve-references'" - (when (or (consp (soap-port-binding port)) - (stringp (soap-port-binding port))) + "Replace names in PORT with the referenced objects in the WSDL. +This is a generic function, called by `soap-resolve-references', +you should use that function instead. + +See also `soap-wsdl-resolve-references'." + (when (soap-name-p (soap-port-binding port)) (setf (soap-port-binding port) (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p)))) ;; Install resolvers for our types (progn - (put (aref (make-soap-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 - 'soap-resolve-references-for-array-type) (put (aref (make-soap-message) 0) 'soap-resolve-references 'soap-resolve-references-for-message) (put (aref (make-soap-operation) 0) 'soap-resolve-references @@ -745,312 +2307,173 @@ soap-wsdl-resolve-references (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl) (throw 'done t))))) - (maphash (lambda (name element) + (maphash (lambda (_name element) (cond ((soap-element-p element) ; skip links (incf nprocessed) - (soap-resolve-references-for-element element wsdl) - (setf (soap-element-namespace-tag element) nstag)) + (soap-resolve-references element wsdl)) ((listp element) (dolist (e element) (when (soap-element-p e) (incf nprocessed) - (soap-resolve-references-for-element e wsdl) - (setf (soap-element-namespace-tag e) nstag)))))) + (soap-resolve-references e wsdl)))))) (soap-namespace-elements ns))))) - wsdl) + wsdl) ;;;;; Loading WSDL from XML documents -(defun soap-load-wsdl-from-url (url) - "Load a WSDL document from URL and return it. -The returned WSDL document needs to be used for `soap-invoke' -calls." - (let ((url-request-method "GET") +(defun soap-parse-server-response () + "Error-check and parse the XML contents of the current buffer." + (let ((mime-part (mm-dissect-buffer t t))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (prog1 + (car (xml-parse-region (point-min) (point-max))) + (kill-buffer) + (mm-destroy-part mime-part))))) + +(defun soap-fetch-xml-from-url (url wsdl) + "Load an XML document from URL and return it. +The previously parsed URL is read from WSDL." + (message "Fetching from %s" url) + (let ((current-file (url-expand-file-name url (soap-wsdl-current-file wsdl))) + (url-request-method "GET") (url-package-name "soap-client.el") (url-package-version "1.0") (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") - (url-request-coding-system 'utf-8) - (url-http-attempt-keepalives nil)) - (let ((buffer (url-retrieve-synchronously url))) + (url-http-attempt-keepalives t)) + (setf (soap-wsdl-current-file wsdl) current-file) + (let ((buffer (url-retrieve-synchronously current-file))) (with-current-buffer buffer (declare (special url-http-response-status)) (if (> url-http-response-status 299) (error "Error retrieving WSDL: %s" url-http-response-status)) - (let ((mime-part (mm-dissect-buffer t t))) - (unless mime-part - (error "Failed to decode response from server")) - (unless (equal (car (mm-handle-type mime-part)) "text/xml") - (error "Server response is not an XML document")) - (with-temp-buffer - (mm-insert-part mime-part) - (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max))))) - (prog1 - (let ((wsdl (soap-parse-wsdl wsdl-xml))) - (setf (soap-wsdl-origin wsdl) url) - wsdl) - (kill-buffer buffer))))))))) - -(defun soap-load-wsdl (file) - "Load a WSDL document from FILE and return it." - (with-temp-buffer - (insert-file-contents file) - (let ((xml (car (xml-parse-region (point-min) (point-max))))) - (let ((wsdl (soap-parse-wsdl xml))) - (setf (soap-wsdl-origin wsdl) file) - wsdl)))) - -(defun soap-parse-wsdl (node) - "Construct a WSDL structure from NODE, which is an XML document." + (soap-parse-server-response))))) + +(defun soap-fetch-xml-from-file (file wsdl) + "Load an XML document from FILE and return it. +The previously parsed file is read from WSDL." + (let* ((current-file (soap-wsdl-current-file wsdl)) + (expanded-file (expand-file-name file + (if current-file + (file-name-directory current-file) + default-directory)))) + (setf (soap-wsdl-current-file wsdl) expanded-file) + (with-temp-buffer + (insert-file-contents expanded-file) + (car (xml-parse-region (point-min) (point-max)))))) + +(defun soap-fetch-xml (file-or-url wsdl) + "Load an XML document from FILE-OR-URL and return it. +The previously parsed file or URL is read from WSDL." + (let ((current-file (or (soap-wsdl-current-file wsdl) file-or-url))) + (if (or (and current-file (file-exists-p current-file)) + (file-exists-p file-or-url)) + (soap-fetch-xml-from-file file-or-url wsdl) + (soap-fetch-xml-from-url file-or-url wsdl)))) + +(defun soap-load-wsdl (file-or-url &optional wsdl) + "Load a document from FILE-OR-URL and return it. +Build on WSDL if it is provided." + (let* ((wsdl (or wsdl (soap-make-wsdl file-or-url))) + (xml (soap-fetch-xml file-or-url wsdl))) + (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl)) + wsdl)) + +(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl) + +(defun soap-parse-wsdl-phase-validate-node (node) + "Assert that NODE is valid." (soap-with-local-xmlns node + (let ((node-name (soap-l2wk (xml-node-name node)))) + (assert (eq node-name 'wsdl:definitions) + nil + "expecting wsdl:definitions node, got %s" node-name)))) - (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions) - nil - "soap-parse-wsdl: expecting wsdl:definitions node, got %s" - (soap-l2wk (xml-node-name node))) - - (let ((wsdl (make-soap-wsdl))) - - ;; Add the local alias table to the wsdl document -- it will be used for - ;; all types in this document even after we finish parsing it. - (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns) - - ;; Add the XSD types to the wsdl document - (let ((ns (soap-default-xsd-types))) - (soap-wsdl-add-namespace ns wsdl) - (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl)) - - ;; Add the soapenc types to the wsdl document - (let ((ns (soap-default-soapenc-types))) - (soap-wsdl-add-namespace ns wsdl) - (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl)) - - ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes - ;; and build our type-library - - (let ((types (car (soap-xml-get-children1 node 'wsdl:types)))) - (dolist (node (xml-node-children types)) - ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) - ;; because each node can install its own alias type so the schema - ;; nodes might have a different prefix. - (when (consp node) - (soap-with-local-xmlns node - (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) - (soap-wsdl-add-namespace (soap-parse-schema node) wsdl)))))) - - (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) - (dolist (node (soap-xml-get-children1 node 'wsdl:message)) - (soap-namespace-put (soap-parse-message node) ns)) - - (dolist (node (soap-xml-get-children1 node 'wsdl:portType)) - (let ((port-type (soap-parse-port-type node))) - (soap-namespace-put port-type ns) - (soap-wsdl-add-namespace - (soap-port-type-operations port-type) wsdl))) - - (dolist (node (soap-xml-get-children1 node 'wsdl:binding)) - (soap-namespace-put (soap-parse-binding node) ns)) - - (dolist (node (soap-xml-get-children1 node 'wsdl:service)) - (dolist (node (soap-xml-get-children1 node 'wsdl:port)) - (let ((name (xml-get-attribute node 'name)) - (binding (xml-get-attribute node 'binding)) - (url (let ((n (car (soap-xml-get-children1 - node 'wsdlsoap:address)))) - (xml-get-attribute n 'location)))) - (let ((port (make-soap-port - :name name :binding (soap-l2fq binding 'tns) - :service-url url))) - (soap-namespace-put port ns) - (push port (soap-wsdl-ports wsdl)))))) - - (soap-wsdl-add-namespace ns wsdl)) - - (soap-wsdl-resolve-references wsdl) +(defun soap-parse-wsdl-phase-fetch-imports (node wsdl) + "Fetch and load files imported by NODE into WSDL." + (soap-with-local-xmlns node + (dolist (node (soap-xml-get-children1 node 'wsdl:import)) + (let ((location (xml-get-attribute-or-nil node 'location))) + (when location + (soap-load-wsdl location wsdl)))))) - wsdl))) +(defun soap-parse-wsdl-phase-parse-schema (node wsdl) + "Load types found in NODE into WSDL." + (soap-with-local-xmlns node + ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes and + ;; build our type-library. + (let ((types (car (soap-xml-get-children1 node 'wsdl:types)))) + (dolist (node (xml-node-children types)) + ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) because + ;; each node can install its own alias type so the schema nodes might + ;; have a different prefix. + (when (consp node) + (soap-with-local-xmlns + node + (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + (soap-wsdl-add-namespace (soap-parse-schema node wsdl) + wsdl)))))))) + +(defun soap-parse-wsdl-phase-fetch-schema (node wsdl) + "Fetch and load schema imports defined by NODE into WSDL." + (soap-with-local-xmlns node + (while (soap-wsdl-xmlschema-imports wsdl) + (let* ((import (pop (soap-wsdl-xmlschema-imports wsdl))) + (xml (soap-fetch-xml import wsdl))) + (soap-wsdl-add-namespace (soap-parse-schema xml wsdl) wsdl))))) -(defun soap-parse-schema (node) - "Parse a schema NODE. -Return a SOAP-NAMESPACE containing the elements." +(defun soap-parse-wsdl-phase-finish-parsing (node wsdl) + "Finish parsing NODE into WSDL." (soap-with-local-xmlns node - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) - nil - "soap-parse-schema: expecting an xsd:schema node, got %s" - (soap-l2wk (xml-node-name node))) (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) - ;; NOTE: we only extract the complexTypes from the schema, we wouldn't - ;; know how to handle basic types beyond the built in ones anyway. - (dolist (node (soap-xml-get-children1 node 'xsd: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)) - - (dolist (node (soap-xml-get-children1 node 'xsd:element)) - (soap-namespace-put (soap-parse-schema-element 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) - nil - "soap-parse-schema-element: expecting xsd:element node, got %s" - (soap-l2wk (xml-node-name node))) - (let ((name (xml-get-attribute-or-nil node 'name)) - type) - ;; A schema element that contains an inline complex type -- - ;; construct the actual complex type for it. - (let ((type-node (soap-xml-get-children1 node 'xsd:complexType))) - (when (> (length type-node) 0) - (assert (= (length type-node) 1)) ; only one complex type - ; definition per element - (setq type (soap-parse-complex-type (car type-node))))) - (setf (soap-element-name type) name) - type)) - -(defun soap-parse-complex-type (node) - "Parse NODE and construct a complex type from it." - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType) - nil - "soap-parse-complex-type: expecting xsd:complexType node, got %s" - (soap-l2wk (xml-node-name node))) - (let ((name (xml-get-attribute-or-nil node 'name)) - ;; Use a dummy type for the complex type, it will be replaced - ;; with the real type below, except when the complex type node - ;; is empty... - (type (make-soap-sequence-type :elements nil))) - (dolist (c (xml-node-children node)) - (when (consp c) ; skip string nodes, which are whitespace - (let ((node-name (soap-l2wk (xml-node-name c)))) - (cond - ;; 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))) - ((eq node-name 'xsd:attribute) - ;; The name of this node comes from an attribute tag - (let ((n (xml-get-attribute-or-nil c 'name))) - (setq name n))) - (t - (error "Unknown node type %s" node-name)))))) - (setf (soap-element-name type) name) - type)) - -(defun soap-parse-sequence (node) - "Parse NODE and a list of sequence elements that it defines. -NODE is assumed to be an xsd:sequence node. In that case, each -of its children is assumed to be a sequence element. Each -sequence element is parsed constructing the corresponding type. -A list of these types is returned." - (assert (let ((n (soap-l2wk (xml-node-name node)))) - (memq n '(xsd:sequence xsd:all))) - nil - "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)) - (let ((name (xml-get-attribute-or-nil e 'name)) - (type (xml-get-attribute-or-nil e 'type)) - (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable) "true") - (let ((e (xml-get-attribute-or-nil e 'minOccurs))) - (and e (equal e "0"))))) - (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs))) - (and e (not (equal e "1")))))) - (if type - (setq type (soap-l2fq type 'tns)) - - ;; The node does not have a type, maybe it has a complexType - ;; defined inline... - (let ((type-node (soap-xml-get-children1 e 'xsd:complexType))) - (when (> (length type-node) 0) - (assert (= (length type-node) 1) - nil - "only one complex type definition per element supported") - (setq type (soap-parse-complex-type (car type-node)))))) - - (push (make-soap-sequence-element - :name (intern name) :type type :nillable? nillable? - :multiple? multiple?) - elements))) - (nreverse elements))) - -(defun soap-parse-complex-type-sequence (node) - "Parse NODE as a sequence type." - (let ((elements (soap-parse-sequence node))) - (make-soap-sequence-type :elements elements))) - -(defun soap-parse-complex-type-complex-content (node) - "Parse NODE as a xsd:complexContent node. -A sequence or an array type is returned depending on the actual -contents." - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent) - nil - "soap-parse-complex-type-complex-content: expecting xsd:complexContent node, got %s" - (soap-l2wk (xml-node-name node))) - (let (array? parent elements) - (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension))) - (restriction (car-safe - (soap-xml-get-children1 node 'xsd:restriction)))) - ;; a complex content node is either an extension or a restriction - (cond (extension - (setq parent (xml-get-attribute-or-nil extension 'base)) - (setq elements (soap-parse-sequence - (car (soap-xml-get-children1 - extension 'xsd:sequence))))) - (restriction - (let ((base (xml-get-attribute-or-nil restriction 'base))) - (assert (equal base (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))) - (when (string-match "^\\(.*\\)\\[\\]$" array-type) - (setq parent (match-string 1 array-type)))))) - - (t - (error "Unknown complex type")))) - - (if parent - (setq parent (soap-l2fq parent 'tns))) - - (if array? - (make-soap-array-type :element-type parent) - (make-soap-sequence-type :parent parent :elements elements)))) + (dolist (node (soap-xml-get-children1 node 'wsdl:message)) + (soap-namespace-put (soap-parse-message node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:portType)) + (let ((port-type (soap-parse-port-type node))) + (soap-namespace-put port-type ns) + (soap-wsdl-add-namespace + (soap-port-type-operations port-type) wsdl))) + + (dolist (node (soap-xml-get-children1 node 'wsdl:binding)) + (soap-namespace-put (soap-parse-binding node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:service)) + (dolist (node (soap-xml-get-children1 node 'wsdl:port)) + (let ((name (xml-get-attribute node 'name)) + (binding (xml-get-attribute node 'binding)) + (url (let ((n (car (soap-xml-get-children1 + node 'wsdlsoap:address)))) + (xml-get-attribute n 'location)))) + (let ((port (make-soap-port + :name name :binding (soap-l2fq binding 'tns) + :service-url url))) + (soap-namespace-put port ns) + (push port (soap-wsdl-ports wsdl)))))) + + (soap-wsdl-add-namespace ns wsdl)))) + +(defun soap-parse-wsdl (node wsdl) + "Construct from NODE a WSDL structure, which is an XML document." + ;; Break this into phases to allow for asynchronous parsing. + (soap-parse-wsdl-phase-validate-node node) + ;; Makes synchronous calls. + (soap-parse-wsdl-phase-fetch-imports node wsdl) + (soap-parse-wsdl-phase-parse-schema node wsdl) + ;; Makes synchronous calls. + (soap-parse-wsdl-phase-fetch-schema node wsdl) + (soap-parse-wsdl-phase-finish-parsing node wsdl) + wsdl) (defun soap-parse-message (node) "Parse NODE as a wsdl:message and return the corresponding type." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message) nil - "soap-parse-message: expecting wsdl:message node, got %s" + "expecting wsdl:message node, got %s" (soap-l2wk (xml-node-name node))) (let ((name (xml-get-attribute-or-nil node 'name)) parts) @@ -1062,97 +2485,111 @@ soap-parse-message (when type (setq type (soap-l2fq type 'tns))) - (when element - (setq element (soap-l2fq element 'tns))) + (if element + (setq element (soap-l2fq element 'tns)) + ;; else + (setq element (make-soap-xs-element + :name name + :namespace-tag soap-target-xmlns + :type^ type))) - (push (cons name (or type element)) parts))) + (push (cons name element) parts))) (make-soap-message :name name :parts (nreverse parts)))) (defun soap-parse-port-type (node) "Parse NODE as a wsdl:portType and return the corresponding port." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType) nil - "soap-parse-port-type: expecting wsdl:portType node got %s" + "expecting wsdl:portType node got %s" (soap-l2wk (xml-node-name node))) - (let ((ns (make-soap-namespace - :name (concat "urn:" (xml-get-attribute node 'name))))) + (let* ((soap-target-xmlns (concat "urn:" (xml-get-attribute node 'name))) + (ns (make-soap-namespace :name soap-target-xmlns))) (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))) + (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-element-name o)) - (progn - (soap-namespace-put o ns) + (progn + (soap-namespace-put o ns) - ;; link all messages from this namespace, as this namespace - ;; will be used for decoding the response. - (destructuring-bind (name . message) (soap-operation-input o) - (soap-namespace-put-link name message ns)) + ;; link all messages from this namespace, as this namespace + ;; will be used for decoding the response. + (destructuring-bind (name . message) (soap-operation-input o) + (soap-namespace-put-link name message ns)) - (destructuring-bind (name . message) (soap-operation-output o) - (soap-namespace-put-link name message ns)) + (destructuring-bind (name . message) (soap-operation-output o) + (soap-namespace-put-link name message ns)) - (dolist (fault (soap-operation-faults o)) - (destructuring-bind (name . message) fault - (soap-namespace-put-link name message ns 'replace))) + (dolist (fault (soap-operation-faults o)) + (destructuring-bind (name . message) fault + (soap-namespace-put-link name message ns))) - ))))) + ))))) (make-soap-port-type :name (xml-get-attribute node 'name) - :operations ns))) + :operations ns))) (defun soap-parse-operation (node) "Parse NODE as a wsdl:operation and return the corresponding type." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation) nil - "soap-parse-operation: expecting wsdl:operation node, got %s" + "expecting wsdl:operation node, got %s" (soap-l2wk (xml-node-name node))) (let ((name (xml-get-attribute node 'name)) (parameter-order (split-string - (xml-get-attribute node 'parameterOrder))) - input output faults) + (xml-get-attribute node 'parameterOrder))) + input output faults input-action output-action) (dolist (n (xml-node-children node)) (when (consp n) ; skip string nodes which are whitespace (let ((node-name (soap-l2wk (xml-node-name n)))) (cond - ((eq node-name 'wsdl:input) - (let ((message (xml-get-attribute n 'message)) - (name (xml-get-attribute n 'name))) - (setq input (cons name (soap-l2fq message 'tns))))) - ((eq node-name 'wsdl:output) - (let ((message (xml-get-attribute n 'message)) - (name (xml-get-attribute n 'name))) - (setq output (cons name (soap-l2fq message 'tns))))) - ((eq node-name 'wsdl:fault) - (let ((message (xml-get-attribute n 'message)) - (name (xml-get-attribute n 'name))) - (push (cons name (soap-l2fq message 'tns)) faults))))))) + ((eq node-name 'wsdl:input) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name)) + (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action))) + (setq input (cons name (soap-l2fq message 'tns))) + (setq input-action action))) + ((eq node-name 'wsdl:output) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name)) + (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action))) + (setq output (cons name (soap-l2fq message 'tns))) + (setq output-action action))) + ((eq node-name 'wsdl:fault) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (push (cons name (soap-l2fq message 'tns)) faults))))))) (make-soap-operation :name name + :namespace-tag soap-target-xmlns :parameter-order parameter-order :input input :output output - :faults (nreverse faults)))) + :faults (nreverse faults) + :input-action input-action + :output-action output-action))) (defun soap-parse-binding (node) "Parse NODE as a wsdl:binding and return the corresponding type." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding) nil - "soap-parse-binding: expecting wsdl:binding node, got %s" + "expecting wsdl:binding node, got %s" (soap-l2wk (xml-node-name node))) (let ((name (xml-get-attribute node 'name)) (type (xml-get-attribute node 'type))) (let ((binding (make-soap-binding :name name - :port-type (soap-l2fq type 'tns)))) + :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-headers + soap-body use) (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation)) (setq soap-action (xml-get-attribute-or-nil so 'soapAction))) @@ -1163,9 +2600,24 @@ soap-parse-binding ;; "use"-s for each of them... (dolist (i (soap-xml-get-children1 wo 'wsdl:input)) - (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) - (setq use (or use - (xml-get-attribute-or-nil b 'use))))) + + ;; There can be multiple headers ... + (dolist (h (soap-xml-get-children1 i 'wsdlsoap:header)) + (let ((message (soap-l2fq (xml-get-attribute-or-nil h 'message))) + (part (xml-get-attribute-or-nil h 'part)) + (use (xml-get-attribute-or-nil h 'use))) + (when (and message part) + (push (list message part use) soap-headers)))) + + ;; ... but only one body + (let ((body (car (soap-xml-get-children1 i 'wsdlsoap:body)))) + (setq soap-body (xml-get-attribute-or-nil body 'parts)) + (when soap-body + (setq soap-body + (mapcar #'intern (split-string soap-body + nil + 'omit-nulls)))) + (setq use (xml-get-attribute-or-nil body 'use)))) (unless use (dolist (i (soap-xml-get-children1 wo 'wsdl:output)) @@ -1173,9 +2625,12 @@ soap-parse-binding (setq use (or use (xml-get-attribute-or-nil b 'use)))))) - (puthash name (make-soap-bound-operation :operation name - :soap-action soap-action - :use (and use (intern use))) + (puthash name (make-soap-bound-operation + :operation name + :soap-action soap-action + :soap-headers (nreverse soap-headers) + :soap-body soap-body + :use (and use (intern use))) (soap-binding-operations binding)))) binding))) @@ -1191,10 +2646,6 @@ soap-decoded-multi-refs This is a dynamically bound variable used during decoding the SOAP response.") -(defvar soap-current-wsdl nil - "The current WSDL document used when decoding the SOAP response. -This is a dynamically bound variable.") - (defun soap-decode-type (type node) "Use TYPE (an xsd type) to decode the contents of NODE. @@ -1212,7 +2663,8 @@ soap-decode-type (when decoded (throw 'done decoded))) - (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched + (unless (string-match "^#\\(.*\\)$" href) + (error "Invalid multiRef: %s" href)) (let ((id (match-string 1 href))) (dolist (mr soap-multi-refs) @@ -1227,38 +2679,53 @@ soap-decode-type (soap-with-local-xmlns node (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true") nil - (let ((decoder (get (aref type 0) 'soap-decoder))) - (assert decoder nil "no soap-decoder for %s type" - (aref type 0)) - (funcall decoder type node)))))))) + ;; Handle union types. + (cond ((listp type) + (catch 'done + (dolist (union-member type) + (let* ((decoder (get (aref union-member 0) + 'soap-decoder)) + (result (ignore-errors + (funcall decoder + union-member node)))) + (when result (throw 'done result)))))) + (t + (let ((decoder (get (aref type 0) 'soap-decoder))) + (assert decoder nil + "no soap-decoder for %s type" (aref type 0)) + (funcall decoder type node)))))))))) (defun soap-decode-any-type (node) "Decode NODE using type information inside it." ;; If the NODE has type information, we use that... (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type))) + (when type + (setq type (soap-l2fq 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-xs-type-p))) (if wtype (soap-decode-type wtype node) - ;; The node has type info encoded in it, but we don't know how - ;; to decode it... - (error "Soap-decode-any-type: node has unknown type: %s" type))) + ;; The node has type info encoded in it, but we don't know how + ;; to decode it... + (error "Node has unknown type: %s" type))) - ;; No type info in the node... + ;; No type info in the node... - (let ((contents (xml-node-children node))) - (if (and (= (length contents) 1) (stringp (car contents))) - ;; contents is just a string - (car contents) + (let ((contents (xml-node-children node))) + (if (and (= (length contents) 1) (stringp (car contents))) + ;; contents is just a string + (car contents) - ;; we assume the NODE is a sequence with every element a - ;; structure name - (let (result) - (dolist (element contents) - (let ((key (xml-node-name element)) - (value (soap-decode-any-type element))) - (push (cons key value) result))) - (nreverse result))))))) + ;; we assume the NODE is a sequence with every element a + ;; structure name + (let (result) + (dolist (element contents) + ;; skip any string contents, assume they are whitespace + (unless (stringp element) + (let ((key (xml-node-name element)) + (value (soap-decode-any-type element))) + (push (cons key value) result)))) + (nreverse result))))))) (defun soap-decode-array (node) "Decode NODE as an Array using type information inside it." @@ -1267,90 +2734,23 @@ soap-decode-array (contents (xml-node-children node)) result) (when type - ;; Type is in the format "someType[NUM]" where NUM is the number of - ;; elements in the array. We discard the [NUM] part. - (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type)) - (setq wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p)) - (unless wtype - ;; The node has type info encoded in it, but we don't know how to - ;; decode it... - (error "Soap-decode-array: node has unknown type: %s" type))) + ;; 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 (soap-l2fq type) + soap-current-wsdl 'soap-xs-type-p)) + (unless wtype + ;; The node has type info encoded in it, but we don't know how to + ;; decode it... + (error "Soap-decode-array: node has unknown type: %s" type))) (dolist (e contents) (when (consp e) (push (if wtype (soap-decode-type wtype e) - (soap-decode-any-type e)) + (soap-decode-any-type e)) result))) (nreverse result))) -(defun soap-decode-basic-type (type node) - "Use TYPE to decode the contents of NODE. -TYPE is a `soap-basic-type' struct, and NODE is an XML document. -A LISP value is returned based on the contents of NODE and the -type-info stored in TYPE." - (let ((contents (xml-node-children node)) - (type-kind (soap-basic-type-kind type))) - - (if (null contents) - nil - (ecase type-kind - ((string anyURI) (car contents)) - (dateTime (car contents)) ; TODO: convert to a date time - ((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)) - (Array (soap-decode-array node)))))) - -(defun soap-decode-sequence-type (type node) - "Use TYPE to decode the contents of NODE. -TYPE is assumed to be a sequence type and an ALIST with the -contents of the NODE is returned." - (let ((result nil) - (parent (soap-sequence-type-parent type))) - (when parent - (setq result (nreverse (soap-decode-type parent node)))) - (dolist (element (soap-sequence-type-elements type)) - (let ((instance-count 0) - (e-name (soap-sequence-element-name element)) - (e-type (soap-sequence-element-type element))) - (dolist (node (xml-get-children node e-name)) - (incf instance-count) - (push (cons e-name (soap-decode-type e-type node)) result)) - ;; Do some sanity checking - (cond ((and (= instance-count 0) - (not (soap-sequence-element-nillable? element))) - (soap-warning "While decoding %s: missing non-nillable slot %s" - (soap-element-name type) e-name)) - ((and (> instance-count 1) - (not (soap-sequence-element-multiple? element))) - (soap-warning "While decoding %s: multiple slots named %s" - (soap-element-name type) e-name))))) - (nreverse result))) - -(defun soap-decode-array-type (type node) - "Use TYPE to decode the contents of NODE. -TYPE is assumed to be an array type. Arrays are decoded as lists. -This is because it is easier to work with list results in LISP." - (let ((result nil) - (element-type (soap-array-type-element-type type))) - (dolist (node (xml-node-children node)) - (when (consp node) - (push (soap-decode-type element-type node) result))) - (nreverse result))) - -(progn - (put (aref (make-soap-basic-type) 0) - 'soap-decoder 'soap-decode-basic-type) - ;; 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) - 'soap-decoder 'soap-decode-array-type)) - ;;;; Soap Envelope parsing (define-error 'soap-error "SOAP error") @@ -1362,40 +2762,44 @@ soap-parse-envelope (soap-with-local-xmlns node (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope) nil - "soap-parse-envelope: expecting soap:Envelope node, got %s" + "expecting soap:Envelope node, got %s" (soap-l2wk (xml-node-name node))) - (let ((body (car (soap-xml-get-children1 node 'soap:Body)))) + (let ((headers (soap-xml-get-children1 node 'soap:Header)) + (body (car (soap-xml-get-children1 node 'soap:Body)))) (let ((fault (car (soap-xml-get-children1 body 'soap:Fault)))) (when fault (let ((fault-code (let ((n (car (xml-get-children - fault 'faultcode)))) + fault 'faultcode)))) (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 detail)))))) + (while t + (signal 'soap-error (list fault-code fault-string detail)))))) ;; First (non string) element of the body is the root node of he ;; response (let ((response (if (eq (soap-bound-operation-use operation) 'literal) ;; For 'literal uses, the response is the actual body body - ;; ...otherwise the first non string element - ;; of the body is the response - (catch 'found - (dolist (n (xml-node-children body)) - (when (consp n) - (throw 'found n))))))) - (soap-parse-response response operation wsdl body))))) + ;; ...otherwise the first non string element + ;; of the body is the response + (catch 'found + (dolist (n (xml-node-children body)) + (when (consp n) + (throw 'found n))))))) + (soap-parse-response response operation wsdl headers body))))) -(defun soap-parse-response (response-node operation wsdl soap-body) +(defun soap-parse-response (response-node operation wsdl soap-headers soap-body) "Parse RESPONSE-NODE and return the result as a LISP value. OPERATION is the WSDL operation for which we expect the response, WSDL is used to decode the NODE. +SOAP-HEADERS is a list of the headers of the SOAP envelope or nil +if there are no headers. + 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." @@ -1409,7 +2813,7 @@ soap-parse-response (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-name wsdl 'soap-message-p))) (unless (eq received-message message) (error "Unexpected message: got %s, expecting %s" received-message-name @@ -1426,42 +2830,52 @@ soap-parse-response (setq node (cond - ((eq use 'encoded) - (car (xml-get-children response-node tag))) + ((eq use 'encoded) + (car (xml-get-children response-node tag))) - ((eq use 'literal) - (catch 'found - (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) - (ns-name (cdr (assoc - (soap-element-namespace-tag type) - ns-aliases))) - (fqname (cons ns-name (soap-element-name type)))) - (dolist (c (xml-node-children response-node)) - (when (consp c) - (soap-with-local-xmlns c - (when (equal (soap-l2fq (xml-node-name c)) - fqname) - (throw 'found c)))))))))) + ((eq use 'literal) + (catch 'found + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc + (soap-element-namespace-tag type) + ns-aliases))) + (fqname (cons ns-name (soap-element-name type)))) + (dolist (c (append (mapcar (lambda (header) + (car (xml-node-children + header))) + soap-headers) + (xml-node-children response-node))) + (when (consp c) + (soap-with-local-xmlns c + (when (equal (soap-l2fq (xml-node-name c)) + fqname) + (throw 'found c)))))))))) (unless node (error "Soap-parse-response(%s): cannot find message part %s" (soap-element-name op) tag)) - (push (soap-decode-type type node) decoded-parts))) + (let ((decoded-value (soap-decode-type type node))) + (when decoded-value + (push decoded-value decoded-parts))))) decoded-parts)))) ;;;; SOAP type encoding -(defvar soap-encoded-namespaces nil - "A list of namespace tags used during encoding a message. -This list is populated by `soap-encode-value' and used by -`soap-create-envelope' to add aliases for these namespace to the -XML request. +(defun soap-encode-attributes (value type) + "Encode XML attributes for VALUE according to TYPE. +This is a generic function which determines the attribute encoder +for the type and calls that specialized function to do the work. -This variable is dynamically bound in `soap-create-envelope'.") +Attributes are inserted in the current buffer at the current +position." + (let ((attribute-encoder (get (aref type 0) 'soap-attribute-encoder))) + (assert attribute-encoder nil + "no soap-attribute-encoder for %s type" (aref type 0)) + (funcall attribute-encoder value type))) -(defun soap-encode-value (xml-tag value type) - "Encode inside an XML-TAG the VALUE using TYPE. +(defun soap-encode-value (value type) + "Encode the VALUE using TYPE. The resulting XML data is inserted in the current buffer at (point)/ @@ -1471,190 +2885,24 @@ soap-encode-value work." (let ((encoder (get (aref type 0) 'soap-encoder))) (assert encoder nil "no soap-encoder for %s type" (aref type 0)) - ;; XML-TAG can be a string or a symbol, but we pass only string's to the - ;; encoders - (when (symbolp xml-tag) - (setq xml-tag (symbol-name xml-tag))) - (funcall encoder xml-tag value type)) - (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type))) + (funcall encoder value type)) + (when (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. -Do not call this function directly, use `soap-encode-value' -instead." - (let ((xsi-type (soap-element-fq-name type)) - (basic-type (soap-basic-type-kind type))) - - ;; try to classify the type based on the value type and use that type when - ;; encoding - (when (eq basic-type 'anyType) - (cond ((stringp value) - (setq xsi-type "xsd:string" basic-type 'string)) - ((integerp value) - (setq xsi-type "xsd:int" basic-type 'int)) - ((memq value '(t nil)) - (setq xsi-type "xsd:boolean" basic-type 'boolean)) - (t - (error - "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value" - xml-tag value xsi-type)))) - - (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") - - ;; We have some ambiguity here, as a nil value represents "false" when the - ;; type is boolean, we will never have a "nil" boolean type... - - (if (or value (eq basic-type 'boolean)) - (progn - (insert ">") - (case basic-type - ((string anyURI) - (unless (stringp value) - (error "Soap-encode-basic-type(%s, %s, %s): not a string value" - xml-tag value xsi-type)) - (insert (url-insert-entities-in-string value))) - - (dateTime - (cond ((and (consp value) ; is there a time-value-p ? - (>= (length value) 2) - (numberp (nth 0 value)) - (numberp (nth 1 value))) - ;; Value is a (current-time) style value, convert - ;; to a string - (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value))) - ((stringp value) - (insert (url-insert-entities-in-string value))) - (t - (error - "Soap-encode-basic-type(%s, %s, %s): not a dateTime value" - xml-tag value xsi-type)))) - - (boolean - (unless (memq value '(t nil)) - (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value" - xml-tag value xsi-type)) - (insert (if value "true" "false"))) - - ((long int 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" - xml-tag value xsi-type)) - (insert (base64-encode-string value))) - - (otherwise - (error - "Soap-encode-basic-type(%s, %s, %s): don't know how to encode" - xml-tag value xsi-type)))) - - (insert " xsi:nil=\"true\">")) - (insert "\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' -instead." - (let ((xsi-type (soap-element-fq-name type))) - (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") - (if value - (progn - (insert ">\n") - (let ((parents (list type)) - (parent (soap-sequence-type-parent type))) - - (while parent - (push parent parents) - (setq parent (soap-sequence-type-parent parent))) - - (dolist (type parents) - (dolist (element (soap-sequence-type-elements type)) - (let ((instance-count 0) - (e-name (soap-sequence-element-name element)) - (e-type (soap-sequence-element-type element))) - (dolist (v value) - (when (equal (car v) e-name) - (incf instance-count) - (soap-encode-value e-name (cdr v) e-type))) - - ;; Do some sanity checking - (cond ((and (= instance-count 0) - (not (soap-sequence-element-nillable? element))) - (soap-warning - "While encoding %s: missing non-nillable slot %s" - (soap-element-name type) e-name)) - ((and (> instance-count 1) - (not (soap-sequence-element-multiple? element))) - (soap-warning - "While encoding %s: multiple slots named %s" - (soap-element-name type) e-name)))))))) - (insert " xsi:nil=\"true\">")) - (insert "\n"))) - -(defun soap-encode-array-type (xml-tag value type) - "Encode inside XML-TAG the LISP VALUE according to TYPE. -Do not call this function directly, use `soap-encode-value' -instead." - (unless (vectorp value) - (error "Soap-encode: %s(%s) expects a vector, got: %s" - xml-tag (soap-element-fq-name type) value)) - (let* ((element-type (soap-array-type-element-type type)) - (array-type (concat (soap-element-fq-name element-type) - "[" (format "%s" (length value)) "]"))) - (insert "<" xml-tag - " soapenc:arrayType=\"" array-type "\" " - " xsi:type=\"soapenc:Array\">\n") - (loop for i below (length value) - do (soap-encode-value xml-tag (aref value i) element-type)) - (insert "\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) - 'soap-encoder 'soap-encode-array-type)) - -(defun soap-encode-body (operation parameters wsdl) +(defun soap-encode-body (operation parameters &optional service-url) "Create the body of a SOAP request for OPERATION in the current buffer. PARAMETERS is a list of parameters supplied to the OPERATION. The OPERATION and PARAMETERS are encoded according to the WSDL -document." +document. SERVICE-URL should be provided when WS-Addressing is +being used." (let* ((op (soap-bound-operation-operation operation)) (use (soap-bound-operation-use operation)) (message (cdr (soap-operation-input op))) - (parameter-order (soap-operation-parameter-order op))) + (parameter-order (soap-operation-parameter-order op)) + (param-table (loop for formal in parameter-order + for value in parameters + collect (cons formal value)))) (unless (= (length parameter-order) (length parameters)) (error "Wrong number of parameters for %s: expected %d, got %s" @@ -1662,62 +2910,73 @@ soap-encode-body (length parameter-order) (length parameters))) + (let ((headers (soap-bound-operation-soap-headers operation)) + (input-action (soap-operation-input-action op))) + (when headers + (insert "\n") + (when input-action + (add-to-list 'soap-encoded-namespaces "wsa") + (insert "" input-action "\n") + (insert "" service-url "\n")) + (dolist (h headers) + (let* ((message (nth 0 h)) + (part (assq (nth 1 h) (soap-message-parts message))) + (value (cdr (assoc (car part) (car parameters)))) + (use (nth 2 h)) + (element (cdr part))) + (when (eq use 'encoded) + (when (soap-element-namespace-tag element) + (add-to-list 'soap-encoded-namespaces + (soap-element-namespace-tag element))) + (insert "<" (soap-element-fq-name element) ">\n")) + (soap-encode-value value element) + (when (eq use 'encoded) + (insert "\n")))) + (insert "\n"))) + (insert "\n") (when (eq use 'encoded) - (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op)) + (when (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 - for value in parameters - collect (cons formal value)))) - (dolist (part (soap-message-parts message)) - (let* ((param-name (car part)) - (type (cdr part)) - (tag-name (if (eq use 'encoded) - param-name - (soap-element-name type))) - (value (cdr (assoc param-name param-table))) - (start-pos (point))) - (soap-encode-value tag-name value type) - (when (eq use 'literal) - ;; hack: add the xmlns attribute to the tag, the only way - ;; ASP.NET web services recognize the namespace of the - ;; element itself... - (save-excursion - (goto-char start-pos) - (when (re-search-forward " ") - (let* ((ns (soap-element-namespace-tag type)) - (namespace (cdr (assoc ns - (soap-wsdl-alias-table wsdl))))) - (when namespace - (insert "xmlns=\"" namespace "\" "))))))))) + (dolist (part (soap-message-parts message)) + (let* ((param-name (car part)) + (element (cdr part)) + (value (cdr (assoc param-name param-table)))) + (when (or (null (soap-bound-operation-soap-body operation)) + (member param-name + (soap-bound-operation-soap-body operation))) + (soap-encode-value value element)))) (when (eq use 'encoded) (insert "\n")) (insert "\n"))) -(defun soap-create-envelope (operation parameters wsdl) +(defun soap-create-envelope (operation parameters wsdl &optional service-url) "Create a SOAP request envelope for OPERATION using PARAMETERS. -WSDL is the wsdl document used to encode the PARAMETERS." +WSDL is the wsdl document used to encode the PARAMETERS. +SERVICE-URL should be provided when WS-Addressing is being used." (with-temp-buffer (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc")) (use (soap-bound-operation-use operation))) ;; Create the request body - (soap-encode-body operation parameters wsdl) + (soap-encode-body operation parameters service-url) ;; Put the envelope around the body (goto-char (point-min)) (insert "\n\n") (goto-char (point-max)) (insert "\n")) @@ -1731,24 +2990,13 @@ soap-debug :type 'boolean :group 'soap-client) -(defun soap-invoke (wsdl service operation-name &rest parameters) - "Invoke a SOAP operation and return the result. - -WSDL is used for encoding the request and decoding the response. -It also contains information about the WEB server address that -will service the request. - -SERVICE is the SOAP service to invoke. - -OPERATION-NAME is the operation to invoke. - -PARAMETERS -- the remaining parameters are used as parameters for -the SOAP request. - -NOTE: The SOAP service provider should document the available -operations and their parameters for the service. You can also -use the `soap-inspect' function to browse the available -operations in a WSDL document." +(defun soap-invoke-internal (callback cbargs wsdl service operation-name + &rest parameters) + "Implement `soap-invoke' and `soap-invoke-async'. +If CALLBACK is non-nil, operate asynchronously, then call CALLBACK as (apply +CALLBACK RESPONSE CBARGS), where RESPONSE is the SOAP invocation result. +If CALLBACK is nil, operate synchronously. WSDL, SERVICE, +OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." (let ((port (catch 'found (dolist (p (soap-wsdl-ports wsdl)) (when (equal service (soap-element-name p)) @@ -1758,63 +3006,100 @@ soap-invoke (let* ((binding (soap-port-binding port)) (operation (gethash operation-name - (soap-binding-operations binding)))) + (soap-binding-operations binding)))) (unless operation (error "No operation %s for SOAP service %s" operation-name service)) (let ((url-request-method "POST") (url-package-name "soap-client.el") (url-package-version "1.0") - (url-http-version "1.0") - (url-request-data - ;; url-request-data expects a unibyte string already encoded... - (encode-coding-string - (soap-create-envelope operation parameters wsdl) - 'utf-8)) + (url-request-data + ;; url-request-data expects a unibyte string already encoded... + (encode-coding-string + (soap-create-envelope operation parameters wsdl + (soap-port-service-url port)) + 'utf-8)) (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") - (url-request-coding-system 'utf-8) (url-http-attempt-keepalives t) - (url-request-extra-headers (list - (cons "SOAPAction" - (soap-bound-operation-soap-action - operation)) - (cons "Content-Type" - "text/xml; charset=utf-8")))) - (let ((buffer (url-retrieve-synchronously - (soap-port-service-url port)))) - (condition-case err - (with-current-buffer buffer - (declare (special url-http-response-status)) - (if (null url-http-response-status) - (error "No HTTP response from server")) - (if (and soap-debug (> url-http-response-status 299)) - ;; This is a warning because some SOAP errors come - ;; back with a HTTP response 500 (internal server - ;; error) - (warn "Error in SOAP response: HTTP code %s" - url-http-response-status)) - (let ((mime-part (mm-dissect-buffer t t))) - (unless mime-part - (error "Failed to decode response from server")) - (unless (equal (car (mm-handle-type mime-part)) "text/xml") - (error "Server response is not an XML document")) - (with-temp-buffer - (mm-insert-part mime-part) - (let ((response (car (xml-parse-region - (point-min) (point-max))))) - (prog1 - (soap-parse-envelope response operation wsdl) - (kill-buffer buffer) - (mm-destroy-part mime-part)))))) - (soap-error - ;; Propagate soap-errors -- they are error replies of the - ;; SOAP protocol and don't indicate a communication - ;; problem or a bug in this code. - (signal (car err) (cdr err))) - (error - (when soap-debug - (pop-to-buffer buffer)) - (error (error-message-string err))))))))) + (url-request-extra-headers + (list + (cons "SOAPAction" + (concat "\"" (soap-bound-operation-soap-action + operation) "\"")) + (cons "Content-Type" + "text/xml; charset=utf-8")))) + (if callback + (url-retrieve + (soap-port-service-url port) + (lambda (status) + (let ((data-buffer (current-buffer))) + (unwind-protect + (let ((error-status (plist-get status :error))) + (if error-status + (signal (car error-status) (cdr error-status)) + (apply callback + (soap-parse-envelope + (soap-parse-server-response) + operation wsdl) + cbargs))) + ;; Ensure the url-retrieve buffer is not leaked. + (and (buffer-live-p data-buffer) + (kill-buffer data-buffer)))))) + (let ((buffer (url-retrieve-synchronously + (soap-port-service-url port)))) + (condition-case err + (with-current-buffer buffer + (declare (special url-http-response-status)) + (if (null url-http-response-status) + (error "No HTTP response from server")) + (if (and soap-debug (> url-http-response-status 299)) + ;; This is a warning because some SOAP errors come + ;; back with a HTTP response 500 (internal server + ;; error) + (warn "Error in SOAP response: HTTP code %s" + url-http-response-status)) + (soap-parse-envelope (soap-parse-server-response) + operation wsdl)) + (soap-error + ;; Propagate soap-errors -- they are error replies of the + ;; SOAP protocol and don't indicate a communication + ;; problem or a bug in this code. + (signal (car err) (cdr err))) + (error + (when soap-debug + (pop-to-buffer buffer)) + (error (error-message-string err)))))))))) + +(defun soap-invoke (wsdl service operation-name &rest parameters) + "Invoke a SOAP operation and return the result. + +WSDL is used for encoding the request and decoding the response. +It also contains information about the WEB server address that +will service the request. + +SERVICE is the SOAP service to invoke. + +OPERATION-NAME is the operation to invoke. + +PARAMETERS -- the remaining parameters are used as parameters for +the SOAP request. + +NOTE: The SOAP service provider should document the available +operations and their parameters for the service. You can also +use the `soap-inspect' function to browse the available +operations in a WSDL document." + (apply #'soap-invoke-internal nil nil wsdl service operation-name parameters)) + +(defun soap-invoke-async (callback cbargs wsdl service operation-name + &rest parameters) + "Like `soap-invoke', but call CALLBACK asynchronously with response. +CALLBACK is called as (apply CALLBACK RESPONSE CBARGS), where +RESPONSE is the SOAP invocation result. WSDL, SERVICE, +OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." + (unless callback + (error "Callback argument is nil")) + (apply #'soap-invoke-internal callback cbargs wsdl service operation-name + parameters)) (provide 'soap-client) diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el index 2f9cdcb..7182b79 100644 --- a/lisp/net/soap-inspect.el +++ b/lisp/net/soap-inspect.el @@ -1,9 +1,10 @@ -;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures +;;;; soap-inspect.el -- Interactive WSDL inspector -*- lexical-binding: t -*- ;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Alexandru Harsanyi ;; Created: October 2010 +;; Version: 3.0.0 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; Homepage: http://code.google.com/p/emacs-soap-client @@ -55,86 +56,153 @@ soap-sample-value (funcall sample-value type) (error "Cannot provide sample value for type %s" (aref type 0))))) -(defun soap-sample-value-for-basic-type (type) - "Provide a sample value for TYPE which is a basic type. -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (case (soap-basic-type-kind type) - (string "a string value") - (boolean t) ; could be nil as well - ((long int) (random 4200)) - ;; TODO: we need better sample values for more types. - (t (format "%s" (soap-basic-type-kind type))))) +(defun soap-sample-value-for-xs-basic-type (type) + "Provide a sample value for TYPE, an xs-basic-type. +This is a specialization of `soap-sample-value' for xs-basic-type +objects." + (case (soap-xs-basic-type-kind type) + (string "a string") + (anyURI "an URI") + (QName "a QName") + (dateTime "a time-value-p or string") + (boolean "t or nil") + ((long int integer byte unsignedInt) 42) + ((float double) 3.14) + (base64Binary "a string") + (t (format "%s" (soap-xs-basic-type-kind type))))) -(defun soap-sample-value-for-simple-type (type) - "Provide a sample value for TYPE which is a simple type. -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (let ((enumeration (soap-simple-type-enumeration type))) - (if (> (length enumeration) 1) - (elt enumeration (random (length enumeration))) - (soap-sample-value-for-basic-type type)))) +(defun soap-sample-value-for-xs-element (element) + "Provide a sample value for ELEMENT, a WSDL element. +This is a specialization of `soap-sample-value' for xs-element +objects." + (if (soap-xs-element-name element) + (cons (intern (soap-xs-element-name element)) + (soap-sample-value (soap-xs-element-type element))) + (soap-sample-value (soap-xs-element-type element)))) -(defun soap-sample-value-for-seqence-type (type) - "Provide a sample value for TYPE which is a sequence type. -Values for sequence types are ALISTS of (slot-name . VALUE) for -each sequence element. +(defun soap-sample-value-for-xs-attribute (attribute) + "Provide a sample value for ATTRIBUTE, a WSDL attribute. +This is a specialization of `soap-sample-value' for +soap-xs-attribute objects." + (if (soap-xs-attribute-name attribute) + (cons (intern (soap-xs-attribute-name attribute)) + (soap-sample-value (soap-xs-attribute-type attribute))) + (soap-sample-value (soap-xs-attribute-type attribute)))) -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (let ((sample-value nil)) - (dolist (element (soap-sequence-type-elements type)) - (push (cons (soap-sequence-element-name element) - (soap-sample-value (soap-sequence-element-type element))) - sample-value)) - (when (soap-sequence-type-parent type) - (setq sample-value - (append (soap-sample-value (soap-sequence-type-parent type)) - sample-value))) - sample-value)) +(defun soap-sample-value-for-xs-attribute-group (attribute-group) + "Provide a sample value for ATTRIBUTE-GROUP, a WSDL attribute group. +This is a specialization of `soap-sample-value' for +soap-xs-attribute objects." + (let ((sample-values nil)) + (dolist (attribute (soap-xs-attribute-group-attributes attribute-group)) + (if (soap-xs-attribute-name attribute) + (setq sample-values + (append sample-values + (cons (intern (soap-xs-attribute-name attribute)) + (soap-sample-value (soap-xs-attribute-type + attribute))))) + (setq sample-values + (append sample-values + (soap-sample-value + (soap-xs-attribute-type attribute)))))))) -(defun soap-sample-value-for-array-type (type) - "Provide a sample value for TYPE which is an array type. -Values for array types are LISP vectors of values which are -array's element type. +(defun soap-sample-value-for-xs-simple-type (type) + "Provide a sample value for TYPE, a `soap-xs-simple-type'. +This is a specialization of `soap-sample-value' for +`soap-xs-simple-type' objects." + (append + (mapcar 'soap-sample-value-for-xs-attribute + (soap-xs-type-attributes type)) + (cond + ((soap-xs-simple-type-enumeration type) + (let ((enumeration (soap-xs-simple-type-enumeration type))) + (nth (random (length enumeration)) enumeration))) + ((soap-xs-simple-type-pattern type) + (format "a string matching %s" (soap-xs-simple-type-pattern type))) + ((soap-xs-simple-type-length-range type) + (destructuring-bind (low . high) (soap-xs-simple-type-length-range type) + (cond + ((and low high) + (format "a string between %d and %d chars long" low high)) + (low (format "a string at least %d chars long" low)) + (high (format "a string at most %d chars long" high)) + (t (format "a string OOPS"))))) + ((soap-xs-simple-type-integer-range type) + (destructuring-bind (min . max) (soap-xs-simple-type-integer-range type) + (cond + ((and min max) (+ min (random (- max min)))) + (min (+ min (random 10))) + (max (random max)) + (t (random 100))))) + ((consp (soap-xs-simple-type-base type)) ; an union of values + (let ((base (soap-xs-simple-type-base type))) + (soap-sample-value (nth (random (length base)) base)))) + ((soap-xs-basic-type-p (soap-xs-simple-type-base type)) + (soap-sample-value (soap-xs-simple-type-base type)))))) -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (let* ((element-type (soap-array-type-element-type type)) - (sample1 (soap-sample-value element-type)) - (sample2 (soap-sample-value element-type))) - ;; Our sample value is a vector of two elements, but any number of - ;; elements are permissible - (vector sample1 sample2 '&etc))) +(defun soap-sample-value-for-xs-complex-type (type) + "Provide a sample value for TYPE, a `soap-xs-complex-type'. +This is a specialization of `soap-sample-value' for +`soap-xs-complex-type' objects." + (append + (mapcar 'soap-sample-value-for-xs-attribute + (soap-xs-type-attributes type)) + (case (soap-xs-complex-type-indicator type) + (array + (let* ((element-type (soap-xs-complex-type-base type)) + (sample1 (soap-sample-value element-type)) + (sample2 (soap-sample-value element-type))) + ;; Our sample value is a vector of two elements, but any number of + ;; elements are permissible + (vector sample1 sample2 '&etc))) + ((sequence choice all) + (let ((base (soap-xs-complex-type-base type))) + (let ((value (append (and base (soap-sample-value base)) + (mapcar #'soap-sample-value + (soap-xs-complex-type-elements type))))) + (if (eq (soap-xs-complex-type-indicator type) 'choice) + (cons '***choice-of*** value) + value))))))) (defun soap-sample-value-for-message (message) "Provide a sample value for a WSDL MESSAGE. -This is a specific function which should not be called directly, -use `soap-sample-value' instead." +This is a specialization of `soap-sample-value' for +`soap-message' objects." ;; NOTE: parameter order is not considered. (let (sample-value) (dolist (part (soap-message-parts message)) - (push (cons (car part) - (soap-sample-value (cdr part))) - sample-value)) + (push (soap-sample-value (cdr part)) sample-value)) (nreverse sample-value))) (progn ;; Install soap-sample-value methods for our types - (put (aref (make-soap-basic-type) 0) 'soap-sample-value - 'soap-sample-value-for-basic-type) + (put (aref (make-soap-xs-basic-type) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-basic-type) - (put (aref (make-soap-simple-type) 0) 'soap-sample-value - 'soap-sample-value-for-simple-type) + (put (aref (make-soap-xs-element) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-element) - (put (aref (make-soap-sequence-type) 0) 'soap-sample-value - 'soap-sample-value-for-seqence-type) + (put (aref (make-soap-xs-attribute) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-attribute) - (put (aref (make-soap-array-type) 0) 'soap-sample-value - 'soap-sample-value-for-array-type) + (put (aref (make-soap-xs-attribute) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-attribute-group) - (put (aref (make-soap-message) 0) 'soap-sample-value - 'soap-sample-value-for-message) ) + (put (aref (make-soap-xs-simple-type) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-simple-type) + + (put (aref (make-soap-xs-complex-type) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-complex-type) + + (put (aref (make-soap-message) 0) + 'soap-sample-value + 'soap-sample-value-for-message)) @@ -184,7 +252,7 @@ soap-inspect (define-button-type 'soap-client-describe-link - 'face 'italic + 'face 'link 'help-echo "mouse-2, RET: describe item" 'follow-link t 'action (lambda (button) @@ -193,10 +261,10 @@ 'soap-client-describe-link 'skip t) (define-button-type 'soap-client-describe-back-link - 'face 'italic + 'face 'link 'help-echo "mouse-2, RET: browse the previous item" 'follow-link t - 'action (lambda (button) + 'action (lambda (_button) (let ((item (pop soap-inspect-previous-items))) (when item (setq soap-inspect-current-item nil) @@ -210,52 +278,142 @@ soap-insert-describe-button 'type 'soap-client-describe-link 'item element)) -(defun soap-inspect-basic-type (basic-type) - "Insert information about BASIC-TYPE into the current buffer." - (insert "Basic type: " (soap-element-fq-name basic-type)) - (insert "\nSample value\n") - (pp (soap-sample-value basic-type) (current-buffer))) +(defun soap-inspect-xs-basic-type (type) + "Insert information about TYPE, a soap-xs-basic-type, in the current buffer." + (insert "Basic type: " (soap-element-fq-name type)) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + +(defun soap-inspect-xs-element (element) + "Insert information about ELEMENT, a soap-xs-element, in the current buffer." + (insert "Element: " (soap-element-fq-name element)) + (insert "\nType: ") + (soap-insert-describe-button (soap-xs-element-type element)) + (insert "\nAttributes:") + (when (soap-xs-element-optional? element) + (insert " optional")) + (when (soap-xs-element-multiple? element) + (insert " multiple")) + (insert "\nSample value:\n") + (pp (soap-sample-value element) (current-buffer))) -(defun soap-inspect-simple-type (simple-type) - "Insert information about SIMPLE-TYPE into the current buffer" - (insert "Simple type: " (soap-element-fq-name simple-type) "\n") - (insert "Base: " (symbol-name (soap-basic-type-kind simple-type)) "\n") - (let ((enumeration (soap-simple-type-enumeration simple-type))) - (when (> (length enumeration) 1) - (insert "Valid values: ") - (dolist (e enumeration) - (insert "\"" e "\" "))))) +(defun soap-inspect-xs-attribute (attribute) + "Insert information about ATTRIBUTE, a soap-xs-attribute, in +the current buffer." + (insert "Attribute: " (soap-element-fq-name attribute)) + (insert "\nType: ") + (soap-insert-describe-button (soap-xs-attribute-type attribute)) + (insert "\nSample value:\n") + (pp (soap-sample-value attribute) (current-buffer))) -(defun soap-inspect-sequence-type (sequence) - "Insert information about SEQUENCE into the current buffer." - (insert "Sequence type: " (soap-element-fq-name sequence) "\n") - (when (soap-sequence-type-parent sequence) - (insert "Parent: ") - (soap-insert-describe-button - (soap-sequence-type-parent sequence)) - (insert "\n")) - (insert "Elements: \n") - (dolist (element (soap-sequence-type-elements sequence)) - (insert "\t" (symbol-name (soap-sequence-element-name element)) - "\t") - (soap-insert-describe-button - (soap-sequence-element-type element)) - (when (soap-sequence-element-multiple? element) - (insert " multiple")) - (when (soap-sequence-element-nillable? element) - (insert " optional")) - (insert "\n")) - (insert "Sample value:\n") - (pp (soap-sample-value sequence) (current-buffer))) +(defun soap-inspect-xs-attribute-group (attribute-group) + "Insert information about ATTRIBUTE-GROUP, a +soap-xs-attribute-group, in the current buffer." + (insert "Attribute group: " (soap-element-fq-name attribute-group)) + (insert "\nSample values:\n") + (pp (soap-sample-value attribute-group) (current-buffer))) -(defun soap-inspect-array-type (array) - "Insert information about the ARRAY into the current buffer." - (insert "Array name: " (soap-element-fq-name array) "\n") - (insert "Element type: ") - (soap-insert-describe-button - (soap-array-type-element-type array)) +(defun soap-inspect-xs-simple-type (type) + "Insert information about TYPE, a soap-xs-simple-type, in the current buffer." + (insert "Simple type: " (soap-element-fq-name type)) + (insert "\nBase: " ) + (if (listp (soap-xs-simple-type-base type)) + (let ((first-time t)) + (dolist (b (soap-xs-simple-type-base type)) + (unless first-time + (insert ", ") + (setq first-time nil)) + (soap-insert-describe-button b))) + (soap-insert-describe-button (soap-xs-simple-type-base type))) + (insert "\nAttributes: ") + (dolist (attribute (soap-xs-simple-type-attributes type)) + (let ((name (or (soap-xs-attribute-name attribute) "*inline*")) + (type (soap-xs-attribute-type attribute))) + (insert "\n\t") + (insert name) + (insert "\t") + (soap-insert-describe-button type))) + (when (soap-xs-simple-type-enumeration type) + (insert "\nEnumeraton values: ") + (dolist (e (soap-xs-simple-type-enumeration type)) + (insert "\n\t") + (pp e))) + (when (soap-xs-simple-type-pattern type) + (insert "\nPattern: " (soap-xs-simple-type-pattern type))) + (when (car (soap-xs-simple-type-length-range type)) + (insert "\nMin length: " + (number-to-string (car (soap-xs-simple-type-length-range type))))) + (when (cdr (soap-xs-simple-type-length-range type)) + (insert "\nMin length: " + (number-to-string (cdr (soap-xs-simple-type-length-range type))))) + (when (car (soap-xs-simple-type-integer-range type)) + (insert "\nMin value: " + (number-to-string (car (soap-xs-simple-type-integer-range type))))) + (when (cdr (soap-xs-simple-type-integer-range type)) + (insert "\nMin value: " + (number-to-string (cdr (soap-xs-simple-type-integer-range type))))) (insert "\nSample value:\n") - (pp (soap-sample-value array) (current-buffer))) + (pp (soap-sample-value type) (current-buffer))) + +(defun soap-inspect-xs-complex-type (type) + "Insert information about TYPE in the current buffer. +TYPE is a `soap-xs-complex-type'" + (insert "Complex type: " (soap-element-fq-name type)) + (insert "\nKind: ") + (case (soap-xs-complex-type-indicator type) + ((sequence all) + (insert "a sequence ") + (when (soap-xs-complex-type-base type) + (insert "extending ") + (soap-insert-describe-button (soap-xs-complex-type-base type))) + (insert "\nAttributes: ") + (dolist (attribute (soap-xs-complex-type-attributes type)) + (let ((name (or (soap-xs-attribute-name attribute) "*inline*")) + (type (soap-xs-attribute-type attribute))) + (insert "\n\t") + (insert name) + (insert "\t") + (soap-insert-describe-button type))) + (insert "\nElements: ") + (let ((name-width 0) + (type-width 0)) + (dolist (element (soap-xs-complex-type-elements type)) + (let ((name (or (soap-xs-element-name element) "*inline*")) + (type (soap-xs-element-type element))) + (setq name-width (max name-width (length name))) + (setq type-width + (max type-width (length (soap-element-fq-name type)))))) + (setq name-width (+ name-width 2)) + (setq type-width (+ type-width 2)) + (dolist (element (soap-xs-complex-type-elements type)) + (let ((name (or (soap-xs-element-name element) "*inline*")) + (type (soap-xs-element-type element))) + (insert "\n\t") + (insert name) + (insert (make-string (- name-width (length name)) ?\ )) + (soap-insert-describe-button type) + (insert + (make-string + (- type-width (length (soap-element-fq-name type))) ?\ )) + (when (soap-xs-element-multiple? element) + (insert " multiple")) + (when (soap-xs-element-optional? element) + (insert " optional")))))) + (choice + (insert "a choice ") + (when (soap-xs-complex-type-base type) + (insert "extending ") + (soap-insert-describe-button (soap-xs-complex-type-base type))) + (insert "\nElements: ") + (dolist (element (soap-xs-complex-type-elements type)) + (insert "\n\t") + (soap-insert-describe-button element))) + (array + (insert "an array of ") + (soap-insert-describe-button (soap-xs-complex-type-base type)))) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + (defun soap-inspect-message (message) "Insert information about MESSAGE into the current buffer." @@ -281,10 +439,11 @@ soap-inspect-operation (insert "\n\nSample invocation:\n") (let ((sample-message-value - (soap-sample-value (cdr (soap-operation-input operation)))) - (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation)))) + (soap-sample-value (cdr (soap-operation-input operation)))) + (funcall (list 'soap-invoke '*WSDL* "SomeService" + (soap-element-name operation)))) (let ((sample-invocation - (append funcall (mapcar 'cdr sample-message-value)))) + (append funcall (mapcar 'cdr sample-message-value)))) (pp sample-invocation (current-buffer))))) (defun soap-inspect-port-type (port-type) @@ -350,17 +509,23 @@ soap-inspect-wsdl (progn ;; Install the soap-inspect methods for our types - (put (aref (make-soap-basic-type) 0) 'soap-inspect - 'soap-inspect-basic-type) + (put (aref (make-soap-xs-basic-type) 0) 'soap-inspect + 'soap-inspect-xs-basic-type) - (put (aref (make-soap-simple-type) 0) 'soap-inspect - 'soap-inspect-simple-type) + (put (aref (make-soap-xs-element) 0) 'soap-inspect + 'soap-inspect-xs-element) - (put (aref (make-soap-sequence-type) 0) 'soap-inspect - 'soap-inspect-sequence-type) + (put (aref (make-soap-xs-simple-type) 0) 'soap-inspect + 'soap-inspect-xs-simple-type) - (put (aref (make-soap-array-type) 0) 'soap-inspect - 'soap-inspect-array-type) + (put (aref (make-soap-xs-complex-type) 0) 'soap-inspect + 'soap-inspect-xs-complex-type) + + (put (aref (make-soap-xs-attribute) 0) 'soap-inspect + 'soap-inspect-xs-attribute) + + (put (aref (make-soap-xs-attribute-group) 0) 'soap-inspect + 'soap-inspect-xs-attribute-group) (put (aref (make-soap-message) 0) 'soap-inspect 'soap-inspect-message) @@ -376,7 +541,7 @@ soap-inspect-wsdl (put (aref (make-soap-port) 0) 'soap-inspect 'soap-inspect-port) - (put (aref (make-soap-wsdl) 0) 'soap-inspect + (put (aref (soap-make-wsdl "origin") 0) 'soap-inspect 'soap-inspect-wsdl)) (provide 'soap-inspect) -- 2.4.3