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

Modified Files: wsdl.lisp xsd.lisp Log Message: more work on xsd type handling in wsdl-soap-call more specifically type element multiplicity added some simple experimental wsdl caching

Date: Thu Sep 22 17:30:00 2005 Author: scaekenberghe

Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.10 cl-soap/src/wsdl.lisp:1.11 --- cl-soap/src/wsdl.lisp:1.10 Wed Sep 21 19:08:03 2005 +++ cl-soap/src/wsdl.lisp Thu Sep 22 17:29:59 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.10 2005/09/21 17:08:03 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.11 2005/09/22 15:29:59 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -342,7 +342,7 @@ (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))))) + (get-element-named (first (get-types wsdl-document-definitions)) element-name))

;; Describing WSDL

@@ -391,15 +391,22 @@ (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)))) + (let ((value (get-name-binding (get-name element) bindings))) + (if value + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,(lisp->xsd-primitive value (intern-xsd-type-name element-type))) + (if (zerop (get-min-occurs element)) + nil + (error "Cannot find binding for ~a" (get-name element)))))) ((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)) + (let* ((sub-bindings (or (get-name-binding (get-name element-type) bindings) + bindings)) + (member-binding (bind-element member sub-bindings wsdl-document-definitions))) + (if member-binding + (push member-binding 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))))) @@ -416,7 +423,8 @@ 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))))) + (unless (zerop (get-min-occurs part-element)) + (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)) @@ -450,17 +458,27 @@ (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)))) + (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t) + (if (zerop (get-min-occurs element)) + (values nil nil) + (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)))) + (let ((resolved-members '())) + (loop :for member :in members :do + (let* ((sub-tag-name (intern (get-name member) (s-xml:get-package namespace))) + (sub-lxml (lxml-find-tag sub-tag-name (rest lxml)))) + (multiple-value-bind (value required) + (resolve-element member sub-lxml wsdl-document-definitions) + (when required + (push (get-name element) resolved-members) + (push value resolved-members))))) + (values (nreverse resolved-members) t)) + (if (zerop (get-min-occurs element)) + (values nil nil) + (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 wsdl-document-definitions) @@ -517,7 +535,7 @@ :|xmlns| ,input-namespace-uri)) ;; we assume there is only one result - (values (first (bind-output-parts result output-message output wsdl-document-definitions)) + (values (bind-output-parts result output-message output wsdl-document-definitions) headers))))

(defun wsdl-soap-rpc-call (wsdl-document-definitions

Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.4 cl-soap/src/xsd.lisp:1.5 --- cl-soap/src/xsd.lisp:1.4 Wed Sep 21 19:08:03 2005 +++ cl-soap/src/xsd.lisp Thu Sep 22 17:30:00 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.4 2005/09/21 17:08:03 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.5 2005/09/22 15:30:00 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -25,8 +25,8 @@ (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) - (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform :unbounded))) + (min-occurs :accessor get-min-occurs :initarg :min-occurs :initform 1) + (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1)))

(defmethod print-object ((object xml-schema-element) out) (print-unreadable-object (object out :type t :identity t) @@ -143,6 +143,9 @@

;;; Interpreting the XSD model

+(defmethod get-element-named ((xml-schema-definition xml-schema-definition) element-name) + (find-item-named element-name (get-elements xml-schema-definition))) + (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)) @@ -180,6 +183,122 @@ (typep first-child 'xsd-sequence)) (get-children first-child))))

+;;; Describing XSD (with pre-rendering of XML) + +(defun indent (n) + (loop :repeat n :do (write-char #\space) (write-char #\space))) + +(defmethod describe-multiplicity ((xml-schema-element xml-schema-element)) + (with-slots (min-occurs max-occurs) + xml-schema-element + (cond ((and (zerop min-occurs) (eql max-occurs 1)) "optional") + ((and (eql min-occurs 1) (eql max-occurs 1)) "required") + ((and (eql min-occurs 1) (eql max-occurs :unbounded)) "one or more") + ((and (zerop min-occurs) (eql max-occurs :unbounded)) "zero or more") + (t (format nil "min:~d-max:~d" min-occurs max-occurs))))) + +(defmethod multiplicity-suffix ((xml-schema-element xml-schema-element)) + (with-slots (min-occurs max-occurs) + xml-schema-element + (cond ((and (zerop min-occurs) (eql max-occurs 1)) "?") + ((and (eql min-occurs 1) (eql max-occurs 1)) "") + ((and (eql min-occurs 1) (eql max-occurs :unbounded)) "+") + ((and (zerop min-occurs) (eql max-occurs :unbounded)) "*") + (t (format nil "~d:~d" min-occurs max-occurs))))) + +(defun pre-render-xsd-type (xml-schema-definition type-name level) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-name))) + (if (typep type-element 'xsd-complex-type) + (let ((members (get-members type-element))) + (loop :for member :in members :do + (let ((member-name (get-name member)) + (member-type (get-type member))) + (indent level) + (if (xsd-primitive-type-name-p member-type) + (format t " <~a>~a</~a>~a~%" + member-name member-type member-name (multiplicity-suffix member)) + (progn + (format t " <~a>~%" member-name) + (pre-render-xsd-type xml-schema-definition member-type (1+ level)) + (indent level) + (format t " </~a>~a~%" member-name (multiplicity-suffix member))))))) + (if (xsd-primitive-type-name-p type) + (progn + (indent level) + (format t " ~a~%" type)) + (error "unexpected type"))))) + +(defun describe-xsd-type (xml-schema-definition type-name level) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-name))) + (if (typep type-element 'xsd-complex-type) + (let ((members (get-members type-element))) + (loop :for member :in members :do + (let ((member-name (get-name member)) + (member-type (get-type member))) + (indent level) + (if (xsd-primitive-type-name-p member-type) + (format t " Member ~s of primitive type ~s [~a]~%" + member-name member-type (describe-multiplicity member)) + (progn + (format t " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (describe-xsd-type xml-schema-definition member-type (1+ level))))))) + (if (xsd-primitive-type-name-p type) + (progn + (indent level) + (format t " primitive type ~a~%" type)) + (error "unexpected type"))))) + +(defun describe-xsd-element (xml-schema-definition element level) + (let* ((element-name (get-name element)) + (element-type (get-element-type xml-schema-definition element-name))) + (if (xsd-primitive-type-name-p element-type) + (progn + (indent level) + (format t "Element ~s of primitive type ~s [~a]~%" + element-name element-type (describe-multiplicity element)) + (indent level) + (format t " <~a>~a</~a>~a~%" element-name element-type element-name (multiplicity-suffix element))) + (let ((members (get-members element-type))) + (indent level) + (format t "Element ~s [~a]~%" element-name (describe-multiplicity element)) + (loop :for member :in members :do + (let ((member-name (get-name member)) + (member-type (get-type member))) + (indent level) + (if (xsd-primitive-type-name-p member-type) + (format t " Member ~s of primitive type ~s [~a]~%" + member-name member-type (describe-multiplicity member)) + (progn + (format t " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (describe-xsd-type xml-schema-definition member-type (1+ level)))))) + (indent level) + (format t " <~a>~%" element-name) + (loop :for member :in members :do + (let ((member-name (get-name member)) + (member-type (get-type member))) + (indent level) + (if (xsd-primitive-type-name-p member-type) + (format t " <~a>~a</~a>~a~%" + member-name member-type member-name (multiplicity-suffix member)) + (progn + (format t " <~a>~%" member-name) + (pre-render-xsd-type xml-schema-definition member-type (1+ level)) + (indent level) + (format t " </~a>~a~%" member-name (multiplicity-suffix member)))))) + (indent level) + (format t " </~a>~a~%" element-name (multiplicity-suffix element)))))) + +(defun describe-xsd (xml-schema-definition) + "Print a high-level description of the top-level elements in xml-schema-definition" + (format t "XML Schema Definition with target-namespace URI ~s~%" + (get-target-namespace xml-schema-definition)) + (loop :for element :in (get-elements xml-schema-definition) :do + (when (typep element 'xml-schema-element) + (describe-xsd-element xml-schema-definition element 1))) + (values)) + ;;; Primitive Types/Values (types are keywords)

(defconstant +known-primitive-type-names+ @@ -196,7 +315,8 @@ "base64Binary" "hexBinary"))

(defun xsd-primitive-type-name-p (name) - (member (actual-name name) +known-primitive-type-names+ :test #'string-equal)) + (and (stringp name) + (member (actual-name name) +known-primitive-type-names+ :test #'string-equal)))

(defun intern-xsd-type-name (name) (intern (string-upcase (actual-name name)) :keyword))