Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv31405/src

Modified Files: lxml.lisp wsdl.lisp xsd.lisp Log Message: added more code to actually implement wsd-soap-call for document oriented soap calls with xsd type descriptions

Date: Wed Sep 21 19:08:03 2005 Author: scaekenberghe

Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.5 cl-soap/src/lxml.lisp:1.6 --- cl-soap/src/lxml.lisp:1.5 Fri Sep 16 09:51:15 2005 +++ cl-soap/src/lxml.lisp Wed Sep 21 19:08:03 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.5 2005/09/16 07:51:15 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.6 2005/09/21 17:08:03 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -24,9 +24,17 @@

(defun lxml-get-attributes (lxml) "Return the XML attributes plist of the lxml XML DOM" - (cond ((or (symbolp lxml) (stringp lxml) (symbolp (first lxml))) '()) + (cond ((or (symbolp lxml) + (stringp lxml) + (symbolp (first lxml))) '()) (t (rest (first lxml)))))

+(defun lxml-get-children (lxml) + "Return the XML children list of the lxml XML DOM" + (cond ((or (symbolp lxml) + (stringp lxml)) '()) + (t (rest lxml)))) + (defun lxml-find-tag (tag lxml) "Find a specific tag in a lxml XML DOM list" (find tag lxml :key #'lxml-get-tag)) @@ -39,5 +47,8 @@ (s-xml:split-identifier qname) (declare (ignore prefix)) identifier)) + +(defun find-item-named (item-name sequence) + (find (actual-name item-name) sequence :test #'string-equal :key #'get-name))

;;;; eof

Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.9 cl-soap/src/wsdl.lisp:1.10 --- cl-soap/src/wsdl.lisp:1.9 Mon Sep 19 20:26:55 2005 +++ cl-soap/src/wsdl.lisp Wed Sep 21 19:08:03 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.9 2005/09/19 18:26:55 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.10 2005/09/21 17:08:03 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -123,7 +123,7 @@ (loop :for element :in (rest lxml) :do (if (eql (lxml-get-tag element) 'xsd:|schema|) (push (lxml->schema-definition element) types))) - types)) + (nreverse types)))

(defun lxml->operation-element (lxml) (let* ((attributes (lxml-get-attributes lxml)) @@ -303,9 +303,6 @@

;; Interpreting the WSDL model

-(defun find-item-named (item-name sequence) - (find (actual-name item-name) sequence :test #'string-equal :key #'get-name)) - (defmethod get-service-named ((wsdl-document-definitions wsdl-document-definitions) service-name) (find-item-named service-name (get-services wsdl-document-definitions)))

@@ -327,6 +324,9 @@ (defmethod get-operation-named ((wsdl-port-type wsdl-port-type) operation-name) (find-item-named operation-name (get-operations wsdl-port-type)))

+(defmethod get-part-named ((wsdl-message wsdl-message) part-name) + (find-item-named part-name (get-parts wsdl-message))) + (defun find-item-of-class (class-name sequence) (let ((class (find-class class-name))) (find-if #'(lambda (c) (eql c class)) sequence :key #'class-of))) @@ -337,6 +337,13 @@ (defmethod get-extension-of-class ((wsdl-extensions-mixin wsdl-extensions-mixin) extension-type) (find-item-of-class extension-type (get-extensions wsdl-extensions-mixin)))

+(defmethod get-extensions-of-class ((wsdl-extensions-mixin wsdl-extensions-mixin) extension-type) + (let ((class (find-class extension-type))) + (remove-if-not #'(lambda (c) (eql c class)) (get-extensions wsdl-extensions-mixin) :key #'class-of))) + +(defmethod get-element-named ((wsdl-document-definitions wsdl-document-definitions) element-name) + (find-item-named element-name (get-elements (first (get-types wsdl-document-definitions))))) + ;; Describing WSDL

(defun describe-wsdl-soap (wsdl-document-definitions) @@ -373,43 +380,148 @@

;; Using WSDL to make structured SOAP calls

-(defun bind-input-parts (input-message input) +(defun get-name-binding (name bindings) + (second (member name bindings :test #'equal))) + +(defun bind-element (element bindings wsdl-document-definitions) + (let* ((element (if (stringp element) + (get-element-named wsdl-document-definitions element) + element)) + (element-type (get-type-in-context element + (get-elements (first (get-types wsdl-document-definitions))))) + (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))) + (cond ((and (stringp element-type) (xsd-primitive-type-name-p element-type)) + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,(lisp->xsd-primitive (get-name-binding (get-name element) bindings) + (intern-xsd-type-name element-type)))) + ((typep element-type 'xsd-complex-type) + (let ((members (get-members element-type)) + (member-actual-bindings '())) + (loop :for member :in members :do + (push (bind-element member bindings wsdl-document-definitions) + member-actual-bindings)) + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,@(nreverse member-actual-bindings)))) + (t (error "Cannot bind element ~s of type ~s" element element-type))))) + +(defun bind-input-parts (input-message input wsdl-document-definitions) (let ((actual-input-parameters '())) (loop :for part :in (get-parts input-message) :do - (let* ((value (second (member (get-name part) input :test #'equal))) - (part-type (get-type part))) - (if value - (push `((,(intern (get-name part) :keyword) - xsi::|type| ,(get-type part)) - ;; basic type conversions ;-) - ,(if (xsd-primitive-type-name-p part-type) - (lisp->xsd-primitive value (intern-xsd-type-name part-type)) - (princ-to-string value))) - actual-input-parameters) - (error "No input binding found for ~a:~a" (get-name input-message) (get-name part))))) + (let ((part-element (get-element part)) + (part-type (get-type part))) + (cond ((xsd-primitive-type-name-p part-type) + (let ((value (get-name-binding (get-name part) input))) + (if value + (push `((,(intern (get-name part) :keyword) ;; default namespace! + xsi::|type| ,part-type) + ,(lisp->xsd-primitive value (intern-xsd-type-name part-type))) + actual-input-parameters) + (error "No input binding found for ~a:~a" (get-name input-message) (get-name part))))) + (part-element + (push (bind-element part-element input wsdl-document-definitions) + actual-input-parameters)) + (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters)))

-(defun bind-headers (headers) - (declare (ignore headers)) - nil) +(defun bind-headers (soap-input-headers headers wsdl-document-definitions) + ;; default namespace! + (let ((actual-headers '())) + (loop :for part :in soap-input-headers :do + (let* ((value (get-name-binding (get-name part) headers)) + (element (get-element-named wsdl-document-definitions (get-element part))) + (type (get-element-type (first (get-types wsdl-document-definitions)) + (get-name element)))) + (if value + (push `(,(intern (get-name part) :keyword) + ,(if (xsd-primitive-type-name-p type) + (lisp->xsd-primitive value (intern-xsd-type-name type)) + (error "Non-primitive header type ~a not allowed" type))) + actual-headers) + (error "No input header binding found for ~a" (get-name part))))) + (nreverse actual-headers))) + +(defun resolve-element (element lxml wsdl-document-definitions) + (let* ((element (if (stringp element) + (get-element-named wsdl-document-definitions element) + element)) + (element-type (get-type-in-context element + (get-elements (first (get-types wsdl-document-definitions))))) + (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))) + (cond ((and (stringp element-type) (xsd-primitive-type-name-p element-type)) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) + (error "Expected a <~a> element" tag-name)))) + ((typep element-type 'xsd-complex-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace))) + (members (get-members element-type))) + (if (eql (lxml-get-tag lxml) tag-name) + (loop :for member :in members :collect + (let* ((sub-tag-name (intern (get-name member) (s-xml:get-package namespace))) + (sub-lxml (lxml-find-tag sub-tag-name (rest lxml)))) + (resolve-element member sub-lxml wsdl-document-definitions))) + (error "Expected a <~a> element" tag-name)))) + (t (error "Cannot bind element ~s of type ~s" element element-type)))))

-(defun bind-output-parts (result output-message output) +(defun bind-output-parts (result output-message output wsdl-document-definitions) + ;; namespaces! (declare (ignore output)) (let ((result-values '())) (loop :for part :in (get-parts output-message) :do - (let* ((part-element (lxml-find-tag (intern (get-name part) :keyword) (rest result))) - (part-value (second part-element)) - (part-type (get-type part))) ;; part-element might have a type attribute as well - ;; basic type conversions ;-) - (if (xsd-primitive-type-name-p part-type) - (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) - result-values) - (push part-value result-values)))) + (let ((part-type (get-type part)) + (part-element (get-element part))) + (cond ((xsd-primitive-type-name-p part-type) + (let* ((tag-name (intern (get-name part) :keyword)) ;; default namespace! + (part-tag (lxml-find-tag tag-name (rest result))) + (part-value (second part-tag))) ;; part-tag might have a type attribute as well + (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) + result-values))) + (part-element + (push (resolve-element part-element result wsdl-document-definitions) + result-values)) + (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) + ;; make the common case more handy (if (= (length result-values) 1) (first result-values) (nreverse result-values))))

-(defun wsdl-soap-rpc-call (soap-end-point +(defun wsdl-soap-document-call (wsdl-document-definitions + soap-end-point + soap-action + input-message + output-message + soap-input-body + soap-input-headers + soap-output-body + input + output + headers) + (let ((input-namespace-uri (or (get-namespace soap-input-body) + (get-target-namespace wsdl-document-definitions))) + (output-namespace-uri (or (get-namespace soap-output-body) + (get-target-namespace wsdl-document-definitions))) + namespace) + (if (equal input-namespace-uri output-namespace-uri) + (setf namespace (or (s-xml:find-namespace input-namespace-uri) + (s-xml:register-namespace input-namespace-uri "ns1" :ns1))) + (error "The case where input and output namespaces differ is not yet supported")) + (multiple-value-bind (result headers) + (soap-call soap-end-point + (bind-headers soap-input-headers headers wsdl-document-definitions) + ;; we assume there is only one parameter + (first (bind-input-parts input-message input wsdl-document-definitions)) + :soap-action soap-action + :envelope-attributes `(,(intern (format nil "xmlns:~a" (s-xml:get-prefix namespace)) + :keyword) + ,input-namespace-uri + :|xmlns| + ,input-namespace-uri)) + ;; we assume there is only one result + (values (first (bind-output-parts result output-message output wsdl-document-definitions)) + headers)))) + +(defun wsdl-soap-rpc-call (wsdl-document-definitions + soap-end-point soap-action binding-operation input-message @@ -417,25 +529,36 @@ soap-input-body soap-output-body input - output - headers) + output) (let ((input-namespace-uri (get-namespace soap-input-body)) (output-namespace-uri (get-namespace soap-output-body))) (if (equal input-namespace-uri output-namespace-uri) (s-xml:register-namespace input-namespace-uri "ns1" :ns1) (error "The case where input and output namespaces differ is not yet supported")) - (let* ((input-wrapper (intern (get-name binding-operation) :ns1)) - (result (soap-call soap-end-point - (bind-headers headers) - `((,input-wrapper - soapenv:|encodingStyle| ,+soap-enc-ns-uri+ - :|xmlns:ns1| ,input-namespace-uri) - ,@(bind-input-parts input-message input)) - :soap-action soap-action)) - (output-wrapper (intern (get-name output-message) :ns1))) - (if (eql (lxml-get-tag result) output-wrapper) - (bind-output-parts result output-message output) - (error "Expected <~a> element" output-wrapper))))) + (let ((input-wrapper (intern (get-name binding-operation) :ns1))) + (multiple-value-bind (result headers) + (soap-call soap-end-point + '() + `((,input-wrapper + soapenv:|encodingStyle| ,+soap-enc-ns-uri+ + :|xmlns:ns1| ,input-namespace-uri) + ,@(bind-input-parts input-message input wsdl-document-definitions)) + :soap-action soap-action) + (let ((output-wrapper (intern (get-name output-message) :ns1))) + (if (eql (lxml-get-tag result) output-wrapper) + (values (bind-output-parts result output-message output wsdl-document-definitions) + headers) + (error "Expected <~a> element" output-wrapper))))))) + +(defun wsdl-soap-input-headers (wsdl-document-definitions binding-operation-input) + (let ((soap-input-headers (get-extensions-of-class binding-operation-input 'wsdl-soap-header)) + (parts '())) + (loop :for soap-input-header :in soap-input-headers :do + (let* ((part-name (get-part soap-input-header)) + (header-message (get-message-named wsdl-document-definitions (get-message soap-input-header)))) + (push (get-part-named header-message part-name) + parts))) + (nreverse parts)))

(defun wsdl-soap-call-internal (wsdl-document-definitions port @@ -453,6 +576,7 @@ (soap-action (get-soap-action soap-operation)) (binding-operation-input (get-operation-element binding-operation 'wsdl-input)) (soap-input-body (get-extension-of-class binding-operation-input 'wsdl-soap-body)) + (soap-input-headers (wsdl-soap-input-headers wsdl-document-definitions binding-operation-input)) (binding-operation-output (get-operation-element binding-operation 'wsdl-output)) (soap-output-body (get-extension-of-class binding-operation-output 'wsdl-soap-body)) (port-type-operation (get-operation-named port-type operation-name)) @@ -461,22 +585,36 @@ (output-message (get-message-named wsdl-document-definitions (get-message (get-operation-element port-type-operation 'wsdl-output))))) (if (string-equal (get-transport soap-binding) "http://schemas.xmlsoap.org/soap/http") - (if (and (string-equal (get-style soap-binding) "rpc") - (string-equal (get-use soap-input-body) "encoded") - (string-equal (get-use soap-output-body) "encoded") - (string-equal (get-encoding-style soap-input-body) "http://schemas.xmlsoap.org/soap/encoding/") - (string-equal (get-encoding-style soap-output-body) "http://schemas.xmlsoap.org/soap/encoding/")) - (wsdl-soap-rpc-call soap-end-point - soap-action - binding-operation - input-message - output-message - soap-input-body - soap-output-body - input - output - headers) - (error "Only standard SOAP RPC style currently supported as binding")) + (cond ((and (string-equal (get-style soap-binding) "rpc") + (string-equal (get-use soap-input-body) "encoded") + (string-equal (get-use soap-output-body) "encoded") + (string-equal (get-encoding-style soap-input-body) "http://schemas.xmlsoap.org/soap/encoding/") + (string-equal (get-encoding-style soap-output-body) "http://schemas.xmlsoap.org/soap/encoding/")) + (wsdl-soap-rpc-call wsdl-document-definitions + soap-end-point + soap-action + binding-operation + input-message + output-message + soap-input-body + soap-output-body + input + output)) + ((and (string-equal (get-style soap-binding) "document") + (string-equal (get-use soap-input-body) "literal") + (string-equal (get-use soap-output-body) "literal")) + (wsdl-soap-document-call wsdl-document-definitions + soap-end-point + soap-action + input-message + output-message + soap-input-body + soap-input-headers + soap-output-body + input + output + headers)) + (t (error "Only standard SOAP RPC and Document style currently supported as binding"))) (error "Only standard SOAP HTTP transport currently supported as binding"))))

;; wsdl: either an instance of wsdl-document-definitions, a string url, a stream to parse, a pathname

Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.3 cl-soap/src/xsd.lisp:1.4 --- cl-soap/src/xsd.lisp:1.3 Mon Sep 19 18:27:04 2005 +++ cl-soap/src/xsd.lisp Wed Sep 21 19:08:03 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.3 2005/09/19 16:27:04 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.4 2005/09/21 17:08:03 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -19,7 +19,10 @@ ((target-namespace :accessor get-target-namespace :initarg :target-namespace :initform nil) (elements :accessor get-elements :initarg :elements :initform nil)))

-(defclass xml-schema-element () +(defclass children-mixin () + ((children :accessor get-children :initarg :children :initform nil))) + +(defclass xml-schema-element (children-mixin) ((name :accessor get-name :initarg :name :initform nil) (type :accessor get-type :initarg :type :initform nil) (min-occurs :accessor get-min-occurs :initarg :min-occurs :initform 0) @@ -29,27 +32,38 @@ (print-unreadable-object (object out :type t :identity t) (prin1 (or (get-name object) "anonymous") out)))

-(defclass xsd-schema-type () +(defclass xsd-type (children-mixin) ((name :accessor get-name :initarg :name :initform nil)))

-(defclass xsd-simple-type (xsd-schema-type) +(defmethod print-object ((object xsd-type) out) + (print-unreadable-object (object out :type t :identity t) + (prin1 (or (get-name object) "anonymous") out))) + +(defclass xsd-simple-type (xsd-type) ())

-(defclass xsd-complex-type (xsd-schema-type) - (children)) +(defclass xsd-complex-type (xsd-type) + ())

-(defclass xsd-compositor () +(defclass xsd-compositor (children-mixin) ())

-(defclass xsd-sequence (xml-compositor) +(defclass xsd-sequence (xsd-compositor) ())

-(defclass xsd-choice (xml-compositor) +(defclass xsd-choice (xsd-compositor) ())

-(defclass xsd-all (xml-compositor) +(defclass xsd-all (xsd-compositor) ())

+(defclass xsd-restriction () + ((base :accessor get-base :initarg :base :initform nil))) + +(defmethod print-object ((object xsd-restriction) out) + (print-unreadable-object (object out :type t :identity t) + (prin1 (or (get-base object) "unknown") out))) + ;;; Parsing

(defun lxml->schema-element (lxml) @@ -57,18 +71,50 @@ (xsd:|element| (let* ((attributes (lxml-get-attributes lxml)) (name (getf attributes :|name|)) - (xml-schema-element (make-instance 'xml-schema-element :name name))) + (type (getf attributes :|type|)) + (min-occurs (getf attributes :|minOccurs|)) + (max-occurs (getf attributes :|maxOccurs|)) + (xml-schema-element (make-instance 'xml-schema-element + :name name + :type type + :min-occurs (if min-occurs (parse-integer min-occurs) 0) + :max-occurs (if max-occurs + (if (equal max-occurs "unbounded") + :unbounded + (parse-integer max-occurs)) + :unbounded)))) + (loop :for child :in (lxml-get-children lxml) :do + (push (lxml->schema-element child) + (get-children xml-schema-element))) xml-schema-element)) (xsd:|simpleType| (let* ((attributes (lxml-get-attributes lxml)) (name (getf attributes :|name|)) - (xml-schema-element (make-instance 'xsd-simple-type :name name))) - xml-schema-element)) + (xsd-type (make-instance 'xsd-simple-type :name name))) + (loop :for child :in (lxml-get-children lxml) :do + (push (lxml->schema-element child) + (get-children xsd-type))) + xsd-type)) (xsd:|complexType| (let* ((attributes (lxml-get-attributes lxml)) (name (getf attributes :|name|)) - (xml-schema-element (make-instance 'xsd-complex-type :name name))) - xml-schema-element)))) + (xsd-type (make-instance 'xsd-complex-type :name name))) + (loop :for child :in (lxml-get-children lxml) :do + (push (lxml->schema-element child) + (get-children xsd-type))) + xsd-type)) + (xsd:|restriction| + (let* ((attributes (lxml-get-attributes lxml)) + (base (getf attributes :|base|)) + (xsd-restriction (make-instance 'xsd-restriction :base base))) + xsd-restriction)) + (xsd:|sequence| + (let ((xsd-sequence (make-instance 'xsd-sequence))) + (loop :for child :in (lxml-get-children lxml) :do + (push (lxml->schema-element child) + (get-children xsd-sequence))) + (setf (get-children xsd-sequence) (nreverse (get-children xsd-sequence))) + xsd-sequence))))

(defun lxml->schema-definition (lxml) (if (eql (lxml-get-tag lxml) 'xsd:|schema|) @@ -97,6 +143,43 @@

;;; Interpreting the XSD model

+(defmethod get-type-in-context ((xsd-simple-type xsd-simple-type) elements) + "For now: return the base type of the restriction child of the simple-type, if any" + (declare (ignore elements)) + (let ((first-child (first (get-children xsd-simple-type)))) + (when (and first-child + (typep first-child 'xsd-restriction)) + (get-base first-child)))) + +(defmethod get-type-in-context ((xsd-complex-type xsd-complex-type) elements) + (declare (ignore elements)) + xsd-complex-type) + +(defmethod get-type-in-context ((xml-schema-element xml-schema-element) elements) + "Resolve the type of element to the most primitive one, in the context of elements" + (let ((type (get-type xml-schema-element))) + (cond (type + (if (xsd-primitive-type-name-p type) + type + (get-type-in-context (find-item-named type elements) elements))) + (t + (let ((first-child (first (get-children xml-schema-element)))) + (when first-child + (get-type-in-context first-child elements))))))) + +(defmethod get-element-type ((xml-schema-definition xml-schema-definition) element-name) + "Resolve the type of element to the most primitive one, in the context of elements" + (let ((element (find-item-named element-name (get-elements xml-schema-definition)))) + (when element + (get-type-in-context element (get-elements xml-schema-definition))))) + +(defmethod get-members ((xsd-complex-type xsd-complex-type)) + "Return the list of members of xsd-complex-type, provided it is a sequence" + (let ((first-child (first (get-children xsd-complex-type)))) + (when (and first-child + (typep first-child 'xsd-sequence)) + (get-children first-child)))) + ;;; Primitive Types/Values (types are keywords)

(defconstant +known-primitive-type-names+ @@ -122,6 +205,21 @@

(defvar *xsd-timezone* nil)

+(defun ut (&optional year month date (hours 0) (minutes 0) (seconds 0)) + "Convenience function to create Common Lisp universal times" + (when (or (null year) (null month) (null date)) + (multiple-value-bind (second minute hour current-date current-month current-year) + (if *xsd-timezone* + (decode-universal-time (get-universal-time) *xsd-timezone*) + (decode-universal-time (get-universal-time))) + (declare (ignore second minute hour)) + (unless year (setf year current-year)) + (unless month (setf month current-month)) + (unless date (setf date current-date)))) + (if *xsd-timezone* + (encode-universal-time seconds minutes hours date month year *xsd-timezone*) + (encode-universal-time seconds minutes hours date month year))) + (defun lisp->xsd-datetime (universal-time) "1999-05-31T13:20:00.000-05:00" (multiple-value-bind (second minute hour date month year day daylight-p timezone) @@ -236,7 +334,7 @@ :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger :long :unsignedLong :int :unsignedInt :short :unsignedShort :byte :decimal) - (parse-integer value) 'integer) + (parse-integer value)) (:float (coerce (read-from-string value) 'float)) (:double