- cl-soap-cvs@common-lisp.net - mailman3.common-lisp.net

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv26091/test Modified Files: test-google-adwords.lisp Log Message: added new, better structured new-bind-element & new-resolve-element functions to xsd to bind wsdl-soap-call document-style input/output binding Date: Fri Sep 23 23:33:06 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.7 cl-soap/test/test-google-adwords.lisp:1.8 --- cl-soap/test/test-google-adwords.lisp:1.7 Fri Sep 23 10:03:46 2005 +++ cl-soap/test/test-google-adwords.lisp Fri Sep 23 23:33:06 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.7 2005/09/23 08:03:46 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.8 2005/09/23 21:33:06 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -226,7 +226,7 @@ :input (mapcar #'(lambda (keyword) (destructuring-bind (text type max-cpc) keyword - `("keywordRequest" ("text" ,text "type" ,type "maxCpc" ,max-cpc)))) + `("KeywordRequest" ("text" ,text "type" ,type "maxCpc" ,max-cpc)))) keywords) :headers `("email" ,*google-adwords-email* "password" ,*google-adwords-password*

1 0

[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv26091/src Modified Files: wsdl.lisp xsd.lisp Log Message: added new, better structured new-bind-element & new-resolve-element functions to xsd to bind wsdl-soap-call document-style input/output binding Date: Fri Sep 23 23:33:05 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.14 cl-soap/src/wsdl.lisp:1.15 --- cl-soap/src/wsdl.lisp:1.14 Fri Sep 23 10:39:13 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.14 2005/09/23 08:39:13 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.15 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -413,10 +413,10 @@ (unless (is-optional-p 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 - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (push (new-bind-element part-element + input + (get-xml-schema-definition wsdl-document-definitions) + namespace) actual-input-parameters)) (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) @@ -453,11 +453,13 @@ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) result-values))) (part-element - (push (resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) - result-values)) + (multiple-value-bind (value required) + (new-resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) + (when required + (push value 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) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.9 cl-soap/src/xsd.lisp:1.10 --- cl-soap/src/xsd.lisp:1.9 Fri Sep 23 10:41:51 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.9 2005/09/23 08:41:51 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.10 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -204,7 +204,7 @@ ;;; Binding and Resolving elements to and from actual data (defun get-name-binding (name bindings) - (second (member name bindings :test #'equal))) + (second (member (actual-name name) bindings :test #'equal))) (defun bind-element (element bindings xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) @@ -230,6 +230,99 @@ ,@(nreverse member-actual-bindings)))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) +(defun new-binding-primitive-value (name type bindings) + (let ((value (get-name-binding name bindings))) + (when value + (lisp->xsd-primitive value (intern-xsd-type-name type))))) + +(defun new-bind-primitive (element type-name bindings namespace) + (let ((value (new-binding-primitive-value (get-name element) type-name bindings))) + (if value + `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) + (if (is-optional-p element) + nil + (error "Cannot find binding for ~a" (get-name element)))))) + +(defun new-bind-type (type-name bindings super-element xml-schema-definition namespace) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type)) + (members-actual-bindings '())) + (loop :for member :in members :do + (let ((member-name (get-name member)) + (member-type (get-type member)) + (sub-bindings (or (get-name-binding (get-name type-element) bindings) + bindings))) + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type sub-bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-bindings member xml-schema-definition namespace) + (if bound + (push `(,(intern member-name (s-xml:get-package namespace)) + ,member-binding) + members-actual-bindings) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name))))))) + (values (nreverse members-actual-bindings) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (new-binding-primitive-value (get-name super-element) type bindings))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-bind-element (element bindings xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (new-bind-primitive element element-type bindings namespace)) + ((typep element-type 'xsd-complex-type) + (let ((members (get-members element-type)) + (members-actual-bindings '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for sub-binding :in bindings :do + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type + sub-binding namespace))) + (when member-binding + (incf count) + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-binding member + xml-schema-definition namespace) + (when bound + (incf count) + (push `(,(intern member-name (s-xml:get-package namespace)) + ,@member-binding) + members-actual-bindings))))) + (if (zerop count) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name)))) + (let ((sub-bindings (or (get-name-binding member-type bindings) + bindings))) + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type + bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-bindings member + xml-schema-definition namespace) + (if bound + (push `(,(intern member-name (s-xml:get-package namespace)) + ,@member-binding) + members-actual-bindings) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name))))))))) + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,@(nreverse members-actual-bindings)))) + (t (error "Cannot bind element ~s of type ~s" element element-type))))) + (defun resolve-element (element lxml xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) (element-type (get-element-type xml-schema-definition element))) @@ -254,10 +347,109 @@ (push (get-name element) resolved-members) (push value resolved-members))))) (values (nreverse resolved-members) t)) - (if (zerop (get-min-occurs element)) + (if (is-optional-p element) (values nil nil) (error "Expected a <~a> element" tag-name))))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) + +(defun new-lxml-primitive-value (name type lxml namespace) + (let ((tag-name (intern name (s-xml:get-package namespace)))) + (when (eql (lxml-get-tag lxml) tag-name) + (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type))))) + +(defun new-resolve-primitive (element type-name lxml namespace) + (let ((value (new-lxml-primitive-value (get-name element) type-name lxml namespace))) + (if value + (values value t) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" (get-name element)))))) + +(defun new-resolve-type (type-name lxml super-element xml-schema-definition namespace) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace))) + (member-lxml (lxml-find-tag sub-tag-name lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))) + (values (nreverse resolved-members) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-resolve-element (element lxml xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (new-resolve-primitive element element-type lxml namespace)) + ((typep element-type 'xsd-complex-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (let ((sub-lxml (lxml-get-children lxml)) + (members (get-members element-type)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in sub-lxml :do + (let ((sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members)))) + (error "Expected a <~a> element" sub-tag-name)))) + (if (zerop count) + (unless (is-optional-p member) + (error "Required element <~a> not found" member-name)))) + (let* ((sub-tag-name (intern member-name (s-xml:get-package namespace))) + (member-lxml (lxml-find-tag sub-tag-name sub-lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) + (values (list (get-name element) (nreverse resolved-members)) t)) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" tag-name))))) + (t (error "Cannot resolve element ~s of type ~s" element element-type))))) ;;; Describing XSD (with pre-rendering of XML)

1 0

[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv4340/src Modified Files: xsd.lisp Log Message: bugfix Date: Fri Sep 23 10:41:55 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.8 cl-soap/src/xsd.lisp:1.9 --- cl-soap/src/xsd.lisp:1.8 Fri Sep 23 10:39:13 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 10:41:51 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.8 2005/09/23 08:39:13 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.9 2005/09/23 08:41:51 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -204,7 +204,7 @@ ;;; Binding and Resolving elements to and from actual data (defun get-name-binding (name bindings) - (second (member name bindings :test #'string-equal))) + (second (member name bindings :test #'equal))) (defun bind-element (element bindings xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element))

1 0

[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv4304/src Modified Files: wsdl.lisp xsd.lisp Log Message: moved bind-element & resolve-element from wsdl.lisp to xsd.lisp preparing for refactoring/rewriting Date: Fri Sep 23 10:39:14 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.13 cl-soap/src/wsdl.lisp:1.14 --- cl-soap/src/wsdl.lisp:1.13 Fri Sep 23 10:06:36 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 23 10:39:13 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.13 2005/09/23 08:06:36 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.14 2005/09/23 08:39:13 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -397,38 +397,9 @@ ;; Using WSDL to make structured SOAP calls -(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-xml-schema-definition wsdl-document-definitions))) - (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))) - (cond ((xsd-primitive-type-name-p 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 (is-optional-p 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 - (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))))) - (defun bind-input-parts (input-message input wsdl-document-definitions) - (let ((actual-input-parameters '())) + (let ((namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) + (actual-input-parameters '())) (loop :for part :in (get-parts input-message) :do (let ((part-element (get-element part)) (part-type (get-type part))) @@ -442,7 +413,10 @@ (unless (is-optional-p 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) + (push (bind-element part-element + input + (get-xml-schema-definition wsdl-document-definitions) + namespace) actual-input-parameters)) (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) @@ -464,42 +438,11 @@ (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-xml-schema-definition wsdl-document-definitions))) - (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))) - (cond ((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) - (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t) - (if (is-optional-p 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) - (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) ;; namespaces! (declare (ignore output)) - (let ((result-values '())) + (let ((namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) + (result-values '())) (loop :for part :in (get-parts output-message) :do (let ((part-type (get-type part)) (part-element (get-element part))) @@ -510,7 +453,10 @@ (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) + (push (resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) result-values)) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) ;; make the common case more handy Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.7 cl-soap/src/xsd.lisp:1.8 --- cl-soap/src/xsd.lisp:1.7 Fri Sep 23 10:06:38 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 10:39:13 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.7 2005/09/23 08:06:38 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.8 2005/09/23 08:39:13 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -200,6 +200,64 @@ (defmethod is-plural-p ((xml-schema-element xml-schema-element)) (eql (get-max-occurs xml-schema-element) :unbounded)) + +;;; Binding and Resolving elements to and from actual data + +(defun get-name-binding (name bindings) + (second (member name bindings :test #'string-equal))) + +(defun bind-element (element bindings xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p 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 (is-optional-p 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 + (let* ((sub-bindings (or (get-name-binding (get-name element-type) bindings) + bindings)) + (member-binding (bind-element member sub-bindings xml-schema-definition namespace))) + (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))))) + +(defun resolve-element (element lxml xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((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) + (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t) + (if (is-optional-p 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) + (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 xml-schema-definition namespace) + (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))))) ;;; Describing XSD (with pre-rendering of XML)

1 0

[cl-soap-cvs] CVS update: cl-soap/src/namespaces.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv2275/src Modified Files: namespaces.lisp wsdl.lisp xsd.lisp Log Message: some code refactoring/cleanup Date: Fri Sep 23 10:06:42 2005 Author: scaekenberghe Index: cl-soap/src/namespaces.lisp diff -u cl-soap/src/namespaces.lisp:1.6 cl-soap/src/namespaces.lisp:1.7 --- cl-soap/src/namespaces.lisp:1.6 Thu Sep 15 15:37:34 2005 +++ cl-soap/src/namespaces.lisp Fri Sep 23 10:06:36 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: namespaces.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $ +;;;; $Id: namespaces.lisp,v 1.7 2005/09/23 08:06:36 scaekenberghe Exp $ ;;;; ;;;; Definition of some standard XML namespaces commonly needed for SOAP ;;;; @@ -43,7 +43,8 @@ (defconstant +xsi-ns-uri+ "http://www.w3.org/1999/XMLSchema-instance") -;; http://www.w3.org/2000/10/XMLSchema-instance +;; "http://www.w3.org/2000/10/XMLSchema-instance" +;; "http://www.w3.org/2001/XMLSchema" (defpackage :xsi (:nicknames "xsi") Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.12 cl-soap/src/wsdl.lisp:1.13 --- cl-soap/src/wsdl.lisp:1.12 Thu Sep 22 22:37:15 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 23 10:06:36 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.12 2005/09/22 20:37:15 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.13 2005/09/23 08:06:36 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -344,6 +344,11 @@ (defmethod get-element-named ((wsdl-document-definitions wsdl-document-definitions) element-name) (get-element-named (first (get-types wsdl-document-definitions)) element-name)) +(defmethod get-xml-schema-definition ((wsdl-document-definitions wsdl-document-definitions)) + (let ((xsd (first (get-types wsdl-document-definitions)))) + (when (typep xsd 'xml-schema-definition) + xsd))) + ;; Describing WSDL (defun describe-wsdl-soap-part (part xml-schema-definition &key (stream *standard-output*) style) @@ -382,10 +387,12 @@ (get-message output-element)))) (format stream " Input: ~a~%" (get-name input-message)) (loop :for part :in (get-parts input-message) :do - (describe-wsdl-soap-part part xml-schema-definition :stream stream :style style)) + (describe-wsdl-soap-part part xml-schema-definition + :stream stream :style style)) (format stream " Output: ~a~%" (get-name output-message)) (loop :for part :in (get-parts output-message) :do - (describe-wsdl-soap-part part xml-schema-definition :stream stream :style style))))))) + (describe-wsdl-soap-part part xml-schema-definition + :stream stream :style style))))))) (values)) ;; Using WSDL to make structured SOAP calls @@ -397,15 +404,14 @@ (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))))) + (element-type (get-type-in-context element (get-xml-schema-definition 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)) + (cond ((xsd-primitive-type-name-p 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)) + (if (is-optional-p element) nil (error "Cannot find binding for ~a" (get-name element)))))) ((typep element-type 'xsd-complex-type) @@ -433,7 +439,7 @@ xsi::|type| ,part-type) ,(lisp->xsd-primitive value (intern-xsd-type-name part-type))) actual-input-parameters) - (unless (zerop (get-min-occurs part-element)) + (unless (is-optional-p 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) @@ -447,7 +453,7 @@ (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)) + (type (get-element-type (get-xml-schema-definition wsdl-document-definitions) (get-name element)))) (if value (push `(,(intern (get-name part) :keyword) @@ -462,14 +468,13 @@ (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))))) + (element-type (get-type-in-context element (get-xml-schema-definition 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)) + (cond ((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) (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t) - (if (zerop (get-min-occurs element)) + (if (is-optional-p element) (values nil nil) (error "Expected a <~a> element" tag-name))))) ((typep element-type 'xsd-complex-type) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.6 cl-soap/src/xsd.lisp:1.7 --- cl-soap/src/xsd.lisp:1.6 Thu Sep 22 22:37:15 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 10:06:38 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.6 2005/09/22 20:37:15 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.7 2005/09/23 08:06:38 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -155,6 +155,7 @@ (get-base first-child)))) (defmethod get-type-in-context ((xsd-complex-type xsd-complex-type) elements) + "A complex type cannot be reduced further" (declare (ignore elements)) xsd-complex-type) @@ -170,19 +171,36 @@ (when first-child (get-type-in-context first-child elements))))))) -(defmethod get-element-type ((xml-schema-definition xml-schema-definition) element-name) +(defmethod get-element-type ((xml-schema-definition xml-schema-definition) element) "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)))) + (let ((element (if (stringp element) + (find-item-named element (get-elements xml-schema-definition)) + element))) (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" + "Return the list of members of xsd-complex-type, provided it is a sequence (for now)" (let ((first-child (first (get-children xsd-complex-type)))) (when (and first-child (typep first-child 'xsd-sequence)) (get-children first-child)))) +(defmethod get-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 :complex)))) + +(defmethod is-optional-p ((xml-schema-element xml-schema-element)) + (zerop (get-min-occurs xml-schema-element))) + +(defmethod is-plural-p ((xml-schema-element xml-schema-element)) + (eql (get-max-occurs xml-schema-element) :unbounded)) + ;;; Describing XSD (with pre-rendering of XML) (defun indent (n &optional (stream *standard-output*)) @@ -208,9 +226,9 @@ (defun pre-render-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*)) (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))) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type))) (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) @@ -220,7 +238,8 @@ member-name member-type member-name (multiplicity-suffix member)) (progn (format stream " <~a>~%" member-name) - (pre-render-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream) + (pre-render-xsd-type xml-schema-definition member-type + :level (1+ level) :stream stream) (indent level stream) (format stream " </~a>~a~%" member-name (multiplicity-suffix member))))))) (if (xsd-primitive-type-name-p type) @@ -231,9 +250,9 @@ (defun describe-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*)) (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))) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type))) (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) @@ -243,7 +262,8 @@ member-name member-type (describe-multiplicity member)) (progn (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) - (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream)))))) + (describe-xsd-type xml-schema-definition member-type + :level (1+ level) :stream stream)))))) (if (xsd-primitive-type-name-p type) (progn (indent level stream) @@ -253,15 +273,16 @@ (defun describe-xsd-element (xml-schema-definition element &key (level 0) (stream *standard-output*)) (unless (typep element 'xml-schema-element) (setf element (get-element-named xml-schema-definition element))) - (let* ((element-name (get-name element)) - (element-type (get-element-type xml-schema-definition element-name))) + (let* ((element-type (get-element-type xml-schema-definition element)) + (element-name (get-name element))) (if (xsd-primitive-type-name-p element-type) (progn (indent level stream) (format stream "Element ~s of primitive type ~s [~a]~%" element-name element-type (describe-multiplicity element)) (indent level stream) - (format stream " <~a>~a</~a>~a~%" element-name element-type element-name (multiplicity-suffix element))) + (format stream " <~a>~a</~a>~a~%" + element-name element-type element-name (multiplicity-suffix element))) (let ((members (get-members element-type))) (indent level stream) (format stream "Element ~s [~a]~%" element-name (describe-multiplicity element)) @@ -274,7 +295,8 @@ member-name member-type (describe-multiplicity member)) (progn (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) - (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream))))) + (describe-xsd-type xml-schema-definition member-type + :level (1+ level) :stream stream))))) (indent level stream) (format stream " <~a>~%" element-name) (loop :for member :in members :do @@ -298,7 +320,8 @@ (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 :level 1 :stream stream))) + (describe-xsd-element xml-schema-definition element + :level 1 :stream stream))) (values)) ;;; Primitive Types/Values (types are keywords)

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv2248/test Modified Files: test-google-adwords.lisp Log Message: made file loadable moved all manual calls to #+NIL indicated better which methods are supposed to work Date: Fri Sep 23 10:03:48 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.6 cl-soap/test/test-google-adwords.lisp:1.7 --- cl-soap/test/test-google-adwords.lisp:1.6 Thu Sep 22 17:30:01 2005 +++ cl-soap/test/test-google-adwords.lisp Fri Sep 23 10:03:46 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.6 2005/09/22 15:30:01 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.7 2005/09/23 08:03:46 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -17,7 +17,7 @@ (defvar *google-adwords-email*) (defvar *google-adwords-password*) -(defvar *google-adwords-user-agent) +(defvar *google-adwords-user-agent*) (defvar *google-adwords-token*) (defvar *google-client-email*) @@ -41,7 +41,8 @@ ;;; ****************************************************************** ;;; apparently there are different XML Schema Defintion namespace URIs -;;; Google is using (s-xml:register-namespace "http://www.w3.org/2001/XMLSchema" "xsd" :xsd) +;;; Google is using +(s-xml:register-namespace "http://www.w3.org/2001/XMLSchema" "xsd" :xsd) ;;; **************************************************************************************** (defparameter *google-adwords-api-wsdl-urls* @@ -68,6 +69,7 @@ ;;; some test calls +#+NIL (defun get-usage-quota-this-month () (multiple-value-bind (result headers) (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService") @@ -84,7 +86,6 @@ (error "Expected a <getUsageQuotaThisMonthReturn> element"))) (error "Expected a <getUsageQuotaThisMonthResponse> element")))) -#+NIL (defun get-usage-quota-this-month () (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl") "getUsageQuotaThisMonth" @@ -94,6 +95,7 @@ "token" ,*google-adwords-token* "clientEmail" ,*google-client-email*))) +#+NIL (defun get-method-cost (service method &optional (date (ut))) (multiple-value-bind (result headers) (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService") @@ -113,7 +115,6 @@ (error "Expected a <getMethodCostReturn> element"))) (error "Expected a <getMethodCostResponse> element")))) -#+NIL (defun get-method-cost (service method &optional (date (ut))) (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl") "getMethodCost" @@ -126,6 +127,7 @@ "token" ,*google-adwords-token* "clientEmail" ,*google-client-email*))) +#+NIL (defun get-operation-count (start-date &optional (end-date start-date))) (defun get-unit-count (&optional (start-date (ut)) (end-date start-date)) @@ -139,8 +141,10 @@ "token" ,*google-adwords-token* "clientEmail" ,*google-client-email*))) +#+NIL (defun get-unit-count-for-method (service method &optional (start-date (ut)) (end-date start-date))) +#+NIL (defun get-billing-address (client-email) (multiple-value-bind (result headers) (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/AccountService") @@ -155,6 +159,7 @@ (values (rest result) headers) (error "Expected a <getBillingAddressResponse> element")))) +#+NIL (defun get-all-adwords-campaigns (client-email) (multiple-value-bind (result headers) (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/CampaignService") @@ -169,6 +174,7 @@ (values result headers))) (defun get-all-adwords-campaigns (client-email) + ;; to be debugged !! (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl") "getAllAdWordsCampaigns" :input '("dummy" 1) @@ -178,6 +184,7 @@ "token" ,*google-adwords-token* "clientEmail" ,client-email))) +#+NIL (defun get-campaign (id client-email) (multiple-value-bind (result headers) (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/CampaignService") @@ -191,6 +198,7 @@ :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) (values result headers))) +#+NIL (defun estimate-keyword-list (keywords) "((<text> <type> <max-cpc>)*) where type is Broad|Phrase|Exact" (multiple-value-bind (result headers)

1 0

[cl-soap-cvs] CVS update: public_html/index.html
by scaekenberghe＠common-lisp.net 22 Sep '05

22 Sep '05

Update of /project/cl-soap/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv18945 Modified Files: index.html Log Message: some extras Date: Thu Sep 22 22:40:44 2005 Author: scaekenberghe Index: public_html/index.html diff -u public_html/index.html:1.5 public_html/index.html:1.6 --- public_html/index.html:1.5 Thu Sep 15 13:42:49 2005 +++ public_html/index.html Thu Sep 22 22:40:44 2005 @@ -9,6 +9,9 @@ both the client and server parts, using both HTTP and HTTPS as transports as well as the WSDL 1.1 spec ( <a href="http://www.w3.org/TR/2001/NOTE-wsdl-20010315">http://www.w3.org/TR/2001/NOTE-wsdl-20010315</a> ) +and the XML Schema Definition spec +( <a href="http://www.w3.org/TR/xmlschema-1/">http://www.w3.org/TR/xmlschema-1/</a> and + <a href="http://www.w3.org/TR/xmlschema-2/">http://www.w3.org/TR/xmlschema-2/</a> ) on as many CL implementations as possible. Interoperability with various other SOAP implementations and applications will be possible. @@ -44,8 +47,9 @@ but only the so called Document model. We need HTTPS (comes with LispWorks).</li> <li>Without (dynamic) WSDL 1.1 support this would mean manual XML message (document) encoding and decoding - not very difficult but not elegant and tedious.</li> -<li>Therefore there will be support for WSDL and the dynamic generation of -any necessary CL stub code (classes, methods) to access services.</li> +<li>Therefore there will be support for WSDL, XSD +and the dynammic usage of this meta data to access services +and/or the dynamic generation of any necessary CL stub code (classes, methods) to access services.</li> <li>Testing will occur against the live Google AdWords API and against local Apache Axis SOAP 1.1 (possibly 1.2) Java servers (these are used by Google) ( <a href="http://ws.apache.org/axis/">http://ws.apache.org/axis/</a> ).</li> @@ -127,7 +131,8 @@ <li>Test and (im)prove compatibility with other SOAP implementations and applications.</li> <li>Implement server side SOAP (document model).</li> <li>Define WSDL in Lisp (and autogenerate it).</li> -<li>Implement the SOAP RPC model and encoding, both for client and server.</li> +<li>Implement more of WSDL and XSD.</li> +<li>Implement more of the SOAP RPC model and encoding, both for client and server.</li> </ul> </p> <h3>Technical Notes</h3> @@ -157,6 +162,6 @@ Initial developers and contributors will include Sven Van Caekenberghe (Beta Nine), Alain Picard (Memetrics), Ivan Melotte (Beta Nine) and Nicky Peeters (Beta Nine). <p> -<p>$Id: index.html,v 1.5 2005/09/15 11:42:49 scaekenberghe Exp $</p> +<p>$Id: index.html,v 1.6 2005/09/22 20:40:44 scaekenberghe Exp $</p> </body> </html>

1 0

[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 22 Sep '05

22 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv18906/src Modified Files: wsdl.lisp xsd.lisp Log Message: now using xsd element/type description in describe-wsdl-soap Date: Thu Sep 22 22:37:15 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.11 cl-soap/src/wsdl.lisp:1.12 --- cl-soap/src/wsdl.lisp:1.11 Thu Sep 22 17:29:59 2005 +++ cl-soap/src/wsdl.lisp Thu Sep 22 22:37:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.11 2005/09/22 15:29:59 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.12 2005/09/22 20:37:15 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -346,21 +346,33 @@ ;; Describing WSDL -(defun describe-wsdl-soap (wsdl-document-definitions) +(defun describe-wsdl-soap-part (part xml-schema-definition &key (stream *standard-output*) style) + (when (equal style "rpc") + (format stream " Part: ~a" (get-name part))) + (cond ((get-type part) + (format stream " of type: ~a~%" (get-type part))) + ((get-element part) + (describe-xsd-element xml-schema-definition (get-element part) + :level 5 :stream stream)))) + +(defun describe-wsdl-soap (wsdl-document-definitions &key (stream *standard-output*)) "Print a high-level description of the services/ports/operations in wsdl-document-definitions" - (format t "WSDL Document Definitions~@[ named ~a~]~%" (get-name wsdl-document-definitions)) + (format stream "WSDL Document Definitions~@[ named ~a~]~%" (get-name wsdl-document-definitions)) (loop :for service :in (get-services wsdl-document-definitions) :do - (format t " Service: ~a~%" (get-name service)) + (format stream " Service: ~a~%" (get-name service)) (loop :for port :in (get-ports service) :do - (format t " Port: ~a~%" (get-name port)) - (format t " SOAP Address Location ~s~%" (get-location (get-extension port))) + (format stream " Port: ~a~%" (get-name port)) + (format stream " SOAP Address Location ~s~%" (get-location (get-extension port))) (let* ((binding-name (get-binding port)) (binding (get-binding-named wsdl-document-definitions binding-name)) + (soap-binding (get-extension-of-class binding 'wsdl-soap-binding)) + (style (get-style soap-binding)) (port-type-name (get-type binding)) - (port-type (get-port-type-named wsdl-document-definitions port-type-name))) - (format t " Binding: ~a~%" binding-name) + (port-type (get-port-type-named wsdl-document-definitions port-type-name)) + (xml-schema-definition (first (get-types wsdl-document-definitions)))) + (format stream " Binding: ~a SOAP style [~a]~%" binding-name style) (loop :for operation :in (get-operations binding) :do - (format t " Operation: ~a~%" (get-name operation)) + (format stream " Operation: ~a~%" (get-name operation)) (let* ((operation-details (get-operation-named port-type (get-name operation))) (input-element (get-operation-element operation-details 'wsdl-input)) (output-element (get-operation-element operation-details 'wsdl-output)) @@ -368,14 +380,12 @@ (get-message input-element))) (output-message (get-message-named wsdl-document-definitions (get-message output-element)))) - (format t " Input: ~a~%" (get-name input-message)) + (format stream " Input: ~a~%" (get-name input-message)) (loop :for part :in (get-parts input-message) :do - (format t " Part: ~a ~@[(type ~a)~]~@[(element ~a)~]~%" - (get-name part) (get-type part) (get-element part))) - (format t " Output: ~a~%" (get-name output-message)) + (describe-wsdl-soap-part part xml-schema-definition :stream stream :style style)) + (format stream " Output: ~a~%" (get-name output-message)) (loop :for part :in (get-parts output-message) :do - (format t " Part: ~a ~@[(type ~a)~]~@[(element ~a)~]~%" - (get-name part) (get-type part) (get-element part)))))))) + (describe-wsdl-soap-part part xml-schema-definition :stream stream :style style))))))) (values)) ;; Using WSDL to make structured SOAP calls Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.5 cl-soap/src/xsd.lisp:1.6 --- cl-soap/src/xsd.lisp:1.5 Thu Sep 22 17:30:00 2005 +++ cl-soap/src/xsd.lisp Thu Sep 22 22:37:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.5 2005/09/22 15:30:00 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.6 2005/09/22 20:37:15 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -77,12 +77,12 @@ (xml-schema-element (make-instance 'xml-schema-element :name name :type type - :min-occurs (if min-occurs (parse-integer min-occurs) 0) + :min-occurs (if min-occurs (parse-integer min-occurs) 1) :max-occurs (if max-occurs (if (equal max-occurs "unbounded") :unbounded (parse-integer max-occurs)) - :unbounded)))) + 1)))) (loop :for child :in (lxml-get-children lxml) :do (push (lxml->schema-element child) (get-children xml-schema-element))) @@ -185,8 +185,8 @@ ;;; Describing XSD (with pre-rendering of XML) -(defun indent (n) - (loop :repeat n :do (write-char #\space) (write-char #\space))) +(defun indent (n &optional (stream *standard-output*)) + (loop :repeat n :do (write-char #\space stream) (write-char #\space stream))) (defmethod describe-multiplicity ((xml-schema-element xml-schema-element)) (with-slots (min-occurs max-occurs) @@ -206,7 +206,7 @@ ((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) +(defun pre-render-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*)) (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) @@ -214,22 +214,22 @@ (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) - (indent level) + (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format t " <~a>~a</~a>~a~%" + (format stream " <~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))))))) + (format stream " <~a>~%" member-name) + (pre-render-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream) + (indent level stream) + (format stream " </~a>~a~%" member-name (multiplicity-suffix member))))))) (if (xsd-primitive-type-name-p type) (progn - (indent level) - (format t " ~a~%" type)) + (indent level stream) + (format stream " ~a~%" type)) (error "unexpected type"))))) -(defun describe-xsd-type (xml-schema-definition type-name level) +(defun describe-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*)) (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) @@ -237,66 +237,68 @@ (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) - (indent level) + (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format t " Member ~s of primitive type ~s [~a]~%" + (format stream " 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))))))) + (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream)))))) (if (xsd-primitive-type-name-p type) (progn - (indent level) - (format t " primitive type ~a~%" type)) + (indent level stream) + (format stream " primitive type ~a~%" type)) (error "unexpected type"))))) -(defun describe-xsd-element (xml-schema-definition element level) +(defun describe-xsd-element (xml-schema-definition element &key (level 0) (stream *standard-output*)) + (unless (typep element 'xml-schema-element) + (setf element (get-element-named xml-schema-definition element))) (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]~%" + (indent level stream) + (format stream "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))) + (indent level stream) + (format stream " <~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)) + (indent level stream) + (format stream "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) + (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format t " Member ~s of primitive type ~s [~a]~%" + (format stream " 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) + (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream))))) + (indent level stream) + (format stream " <~a>~%" element-name) (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) - (indent level) + (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format t " <~a>~a</~a>~a~%" + (format stream " <~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)))))) + (format stream " <~a>~%" member-name) + (pre-render-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream) + (indent level stream) + (format stream " </~a>~a~%" member-name (multiplicity-suffix member)))))) + (indent level stream) + (format stream " </~a>~a~%" element-name (multiplicity-suffix element)))))) -(defun describe-xsd (xml-schema-definition) +(defun describe-xsd (xml-schema-definition &key (stream *standard-output*)) "Print a high-level description of the top-level elements in xml-schema-definition" - (format t "XML Schema Definition with target-namespace URI ~s~%" + (format stream "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))) + (describe-xsd-element xml-schema-definition element :level 1 :stream stream))) (values)) ;;; Primitive Types/Values (types are keywords)

1 0

[cl-soap-cvs] CVS update: cl-soap/cl-soap.asd
by scaekenberghe＠common-lisp.net 22 Sep '05

22 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap In directory common-lisp.net:/tmp/cvs-serv15598 Modified Files: cl-soap.asd Log Message: fixed dependencies Date: Thu Sep 22 21:58:50 2005 Author: scaekenberghe Index: cl-soap/cl-soap.asd diff -u cl-soap/cl-soap.asd:1.2 cl-soap/cl-soap.asd:1.3 --- cl-soap/cl-soap.asd:1.2 Thu Sep 15 15:37:33 2005 +++ cl-soap/cl-soap.asd Thu Sep 22 21:58:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: cl-soap.asd,v 1.2 2005/09/15 13:37:33 scaekenberghe Exp $ +;;;; $Id: cl-soap.asd,v 1.3 2005/09/22 19:58:50 scaekenberghe Exp $ ;;;; ;;;; The CL-SOAP ASDF system definition ;;;; @@ -29,8 +29,8 @@ (:file "lxml" :depends-on ("package")) (:file "namespaces" :depends-on ("package")) (:file "xsd" :depends-on ("package" "namespaces" "lxml")) - (:file "soap" :depends-on ("package" "xsd" "http-client" "namespaces" "lxml")) - (:file "wsdl" :depends-on ("package"))))) + (:file "soap" :depends-on ("package" "http-client" "namespaces" "lxml")) + (:file "wsdl" :depends-on ("package" "xsd" "namespaces" "lxml" "soap"))))) :depends-on (:s-xml :puri)) ;;;; eof

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 22 Sep '05

22 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv26088/test Modified Files: test-google-adwords.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:01 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.5 cl-soap/test/test-google-adwords.lisp:1.6 --- cl-soap/test/test-google-adwords.lisp:1.5 Wed Sep 21 19:08:04 2005 +++ cl-soap/test/test-google-adwords.lisp Thu Sep 22 17:30:01 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.5 2005/09/21 17:08:04 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.6 2005/09/22 15:30:01 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -58,6 +58,14 @@ (defun parse-all-wsdl () (mapcar #'parse-wsdl-url *google-adwords-api-wsdl-urls*)) +(defvar *wsdl-cache* (make-hash-table :test #'equal)) + +(defun wsdl-cache-get (url) + (let ((cached (gethash url *wsdl-cache*))) + (if cached + cached + (setf (gethash url *wsdl-cache*) (parse-wsdl-url url))))) + ;;; some test calls (defun get-usage-quota-this-month () @@ -78,13 +86,13 @@ #+NIL (defun get-usage-quota-this-month () - (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl" + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl") "getUsageQuotaThisMonth" :headers `("email" ,*google-adwords-email* "password" ,*google-adwords-password* "useragent" ,*google-adwords-user-agent* "token" ,*google-adwords-token* - "clientEmail" *google-client-email*))) + "clientEmail" ,*google-client-email*))) (defun get-method-cost (service method &optional (date (ut))) (multiple-value-bind (result headers) @@ -107,7 +115,7 @@ #+NIL (defun get-method-cost (service method &optional (date (ut))) - (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl" + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl") "getMethodCost" :input `("service" ,service "method" ,method @@ -116,12 +124,12 @@ "password" ,*google-adwords-password* "useragent" ,*google-adwords-user-agent* "token" ,*google-adwords-token* - "clientEmail" *google-client-email*))) + "clientEmail" ,*google-client-email*))) (defun get-operation-count (start-date &optional (end-date start-date))) (defun get-unit-count (&optional (start-date (ut)) (end-date start-date)) - (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl" + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl") "getUnitCount" :input `("startDate" ,start-date "endDate" ,end-date) @@ -160,6 +168,16 @@ :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) (values result headers))) +(defun get-all-adwords-campaigns (client-email) + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl") + "getAllAdWordsCampaigns" + :input '("dummy" 1) + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token* + "clientEmail" ,client-email))) + (defun get-campaign (id client-email) (multiple-value-bind (result headers) (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/CampaignService") @@ -195,7 +213,7 @@ (defun estimate-keyword-list (keywords) "((<text> <type> <max-cpc>)*) where type is Broad|Phrase|Exact" - (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl" + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl") "estimateKeywordList" :input (mapcar #'(lambda (keyword) (destructuring-bind (text type max-cpc)

1 0

[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 22 Sep '05

22 Sep '05

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))

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 21 Sep '05

21 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv31405/test Modified Files: test-google-adwords.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:05 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.4 cl-soap/test/test-google-adwords.lisp:1.5 --- cl-soap/test/test-google-adwords.lisp:1.4 Mon Sep 19 19:54:49 2005 +++ cl-soap/test/test-google-adwords.lisp Wed Sep 21 19:08:04 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.4 2005/09/19 17:54:49 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.5 2005/09/21 17:08:04 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -19,6 +19,7 @@ (defvar *google-adwords-password*) (defvar *google-adwords-user-agent) (defvar *google-adwords-token*) +(defvar *google-client-email*) ;;; constants @@ -28,15 +29,21 @@ (:nicknames "google") (:export ;; headers - "email" "password" "useragent" "token" + "email" "password" "useragent" "token" "clientEmail" ;; info service - "getUsageQuotaThisMonth" "getUsageQuotaThisMonthResponse" "getUsageQuotaThisMonthReturn") + "getUsageQuotaThisMonth" "getUsageQuotaThisMonthResponse" "getUsageQuotaThisMonthReturn" + "getCampaigns" "getCampaign" "getBillingAddress") (:documentation "Package for symbols in the Google Adwords API XML Namespace")) (defparameter *google-adwords-ns* (s-xml:register-namespace +google-adwords-ns-uri+ "google" :google)) ;;; basic WSDL parsing +;;; ****************************************************************** +;;; apparently there are different XML Schema Defintion namespace URIs +;;; Google is using (s-xml:register-namespace "http://www.w3.org/2001/XMLSchema" "xsd" :xsd) +;;; **************************************************************************************** + (defparameter *google-adwords-api-wsdl-urls* (loop :for service :in '("CreativeService" "KeywordService" @@ -51,9 +58,9 @@ (defun parse-all-wsdl () (mapcar #'parse-wsdl-url *google-adwords-api-wsdl-urls*)) -;;; manual calls +;;; some test calls -(defun getUsageQuotaThisMonth () +(defun get-usage-quota-this-month () (multiple-value-bind (result headers) (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService") `((google:|email| ,*google-adwords-email*) @@ -70,13 +77,135 @@ (error "Expected a <getUsageQuotaThisMonthResponse> element")))) #+NIL -(defun getUsageQuotaThisMonth () - ;; when we can handle the google type schema this will work ;-) +(defun get-usage-quota-this-month () (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl" "getUsageQuotaThisMonth" :headers `("email" ,*google-adwords-email* "password" ,*google-adwords-password* "useragent" ,*google-adwords-user-agent* - "token" ,*google-adwords-token*))) - + "token" ,*google-adwords-token* + "clientEmail" *google-client-email*))) + +(defun get-method-cost (service method &optional (date (ut))) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*)) + `(google:|getMethodCost| + (google:|service| ,service) + (google:|method| ,method) + (google:|date| ,(lisp->xsd-date date))) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (if (eql (lxml-get-tag result) 'google:|getMethodCostResponse|) + (let ((contents (lxml-find-tag 'google:|getMethodCostReturn| (rest result)))) + (if contents + (values (parse-integer (second contents)) headers) + (error "Expected a <getMethodCostReturn> element"))) + (error "Expected a <getMethodCostResponse> element")))) + +#+NIL +(defun get-method-cost (service method &optional (date (ut))) + (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl" + "getMethodCost" + :input `("service" ,service + "method" ,method + "date" ,date) + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token* + "clientEmail" *google-client-email*))) + +(defun get-operation-count (start-date &optional (end-date start-date))) + +(defun get-unit-count (&optional (start-date (ut)) (end-date start-date)) + (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl" + "getUnitCount" + :input `("startDate" ,start-date + "endDate" ,end-date) + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token* + "clientEmail" ,*google-client-email*))) + +(defun get-unit-count-for-method (service method &optional (start-date (ut)) (end-date start-date))) + +(defun get-billing-address (client-email) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/AccountService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*) + (google:|clientEmail| ,client-email)) + `(google:|getBillingAddress|) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (if (eql (lxml-get-tag result) 'google:|getBillingAddressResponse|) + (values (rest result) headers) + (error "Expected a <getBillingAddressResponse> element")))) + +(defun get-all-adwords-campaigns (client-email) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/CampaignService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*) + (google:|clientEmail| ,client-email)) + `(google:|getAllAdWordsCampaigns| + (google:|dummy| "1")) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (values result headers))) + +(defun get-campaign (id client-email) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/CampaignService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*) + (google:|clientEmail| ,client-email)) + `(google:|getCampaign| + (google:|id| ,(princ-to-string id))) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (values result headers))) + +(defun estimate-keyword-list (keywords) + "((<text> <type> <max-cpc>)*) where type is Broad|Phrase|Exact" + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*)) + `(google::|estimateKeywordList| + ,@(mapcar #'(lambda (keyword) + (destructuring-bind (text type max-cpc) + keyword + `(google::|keywordRequest| + (google::|text| ,text) + (google::|type| ,type) + (google::|maxCpc| ,max-cpc)))) + keywords)) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (values result headers))) + +(defun estimate-keyword-list (keywords) + "((<text> <type> <max-cpc>)*) where type is Broad|Phrase|Exact" + (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl" + "estimateKeywordList" + :input (mapcar #'(lambda (keyword) + (destructuring-bind (text type max-cpc) + keyword + `("keywordRequest" ("text" ,text "type" ,type "maxCpc" ,max-cpc)))) + keywords) + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token* + "clientEmail" ,*google-client-email*))) + ;;;; eof

1 0

[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 21 Sep '05

21 Sep '05

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

1 0

[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp
by scaekenberghe＠common-lisp.net 19 Sep '05

19 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv27664/src Modified Files: wsdl.lisp Log Message: restructured wsdl-soap-call in preparation of extentions Date: Mon Sep 19 20:26:56 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.8 cl-soap/src/wsdl.lisp:1.9 --- cl-soap/src/wsdl.lisp:1.8 Fri Sep 16 14:54:34 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 19 20:26:55 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.8 2005/09/16 12:54:34 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.9 2005/09/19 18:26:55 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -373,6 +373,112 @@ ;; Using WSDL to make structured SOAP calls +(defun bind-input-parts (input-message input) + (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))))) + (nreverse actual-input-parameters))) + +(defun bind-headers (headers) + (declare (ignore headers)) + nil) + +(defun bind-output-parts (result output-message output) + (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)))) + (if (= (length result-values) 1) + (first result-values) + (nreverse result-values)))) + +(defun wsdl-soap-rpc-call (soap-end-point + soap-action + binding-operation + input-message + output-message + soap-input-body + soap-output-body + input + output + headers) + (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))))) + +(defun wsdl-soap-call-internal (wsdl-document-definitions + port + operation-name + input + output + headers) + (let* ((address-location-url (get-location (get-extension port))) + (soap-end-point (make-soap-end-point address-location-url)) + (binding (get-binding-named wsdl-document-definitions (get-binding port))) + (soap-binding (get-extension-of-class binding 'wsdl-soap-binding)) + (port-type (get-port-type-named wsdl-document-definitions (get-type binding))) + (binding-operation (get-operation-named binding operation-name)) + (soap-operation (get-extension-of-class binding-operation 'wsdl-soap-operation)) + (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)) + (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)) + (input-message (get-message-named wsdl-document-definitions + (get-message (get-operation-element port-type-operation 'wsdl-input)))) + (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")) + (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 ;; operation-name: string naming the operation to invoke ;; service-name: string of service to use (if nil, use first service found) @@ -389,7 +495,6 @@ output headers) "Use WSDL to make a SOAP call of operation/port/service using input/output/headers" - (declare (ignore output headers)) (let* ((wsdl-document-definitions (etypecase wsdl (wsdl-document-definitions wsdl) (string (parse-wsdl-url wsdl)) @@ -399,74 +504,12 @@ (first (get-services wsdl-document-definitions)))) (port (if port-name (get-port-named service port-name) - (first (get-ports service)))) - (address-location-url (get-location (get-extension port))) - (soap-end-point (make-soap-end-point address-location-url)) - (binding (get-binding-named wsdl-document-definitions (get-binding port))) - (soap-binding (get-extension-of-class binding 'wsdl-soap-binding)) - (port-type (get-port-type-named wsdl-document-definitions (get-type binding))) - (binding-operation (get-operation-named binding operation-name)) - (soap-operation (get-extension-of-class binding-operation 'wsdl-soap-operation)) - (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)) - (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)) - (input-message (get-message-named wsdl-document-definitions - (get-message (get-operation-element port-type-operation 'wsdl-input)))) - (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/")) - (let ((input-namespace-uri (get-namespace soap-input-body)) - (output-namespace-uri (get-namespace soap-output-body)) - (actual-input-parameters '())) - (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")) - (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* ((input-wrapper (intern (get-name binding-operation) :ns1)) - (result (soap-call soap-end-point - '() - `((,input-wrapper - soapenv:|encodingStyle| ,+soap-enc-ns-uri+ - :|xmlns:ns1| ,input-namespace-uri) - ,@(nreverse actual-input-parameters)) - :soap-action soap-action)) - (output-wrapper (intern (get-name output-message) :ns1)) - (result-values '())) - (if (eql (lxml-get-tag result) output-wrapper) - (progn - (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)))) - (if (= (length result-values) 1) - (first result-values) - (nreverse result-values))) - (error "Expected <~a> element" output-wrapper)))) - (error "Only standard SOAP RPC style currently supported as binding")) - (error "Only standard SOAP HTTP transport currently supported as binding")))) + (first (get-ports service))))) + (wsdl-soap-call-internal wsdl-document-definitions + port + operation-name + input + output + headers))) ;;;; eof

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 19 Sep '05

19 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv25506/test Modified Files: test-google-adwords.lisp Log Message: fixed wsdl spec Date: Mon Sep 19 19:54:49 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.3 cl-soap/test/test-google-adwords.lisp:1.4 --- cl-soap/test/test-google-adwords.lisp:1.3 Mon Sep 19 18:56:14 2005 +++ cl-soap/test/test-google-adwords.lisp Mon Sep 19 19:54:49 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.3 2005/09/19 16:56:14 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.4 2005/09/19 17:54:49 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -72,7 +72,7 @@ #+NIL (defun getUsageQuotaThisMonth () ;; when we can handle the google type schema this will work ;-) - (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService" + (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl" "getUsageQuotaThisMonth" :headers `("email" ,*google-adwords-email* "password" ,*google-adwords-password*

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 19 Sep '05

19 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv21091/test Modified Files: test-google-adwords.lisp Log Message: added return header parsing to soap-call Date: Mon Sep 19 18:56:14 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.2 cl-soap/test/test-google-adwords.lisp:1.3 --- cl-soap/test/test-google-adwords.lisp:1.2 Fri Sep 16 14:54:36 2005 +++ cl-soap/test/test-google-adwords.lisp Mon Sep 19 18:56:14 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.2 2005/09/16 12:54:36 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.3 2005/09/19 16:56:14 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -54,18 +54,18 @@ ;;; manual calls (defun getUsageQuotaThisMonth () - (let* ((xmethods (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService")) - (result (soap-call xmethods - `((google:|email| ,*google-adwords-email*) - (google:|password| ,*google-adwords-password*) - (google:|useragent| ,*google-adwords-user-agent*) - (google:|token| ,*google-adwords-token*)) - `(google:|getUsageQuotaThisMonth|) - :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)))) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*)) + `(google:|getUsageQuotaThisMonth|) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) (if (eql (lxml-get-tag result) 'google:|getUsageQuotaThisMonthResponse|) (let ((contents (lxml-find-tag 'google:|getUsageQuotaThisMonthReturn| (rest result)))) (if contents - (coerce (parse-integer (second contents)) 'integer) + (values (parse-integer (second contents)) headers) (error "Expected a <getUsageQuotaThisMonthReturn> element"))) (error "Expected a <getUsageQuotaThisMonthResponse> element"))))

1 0

[cl-soap-cvs] CVS update: cl-soap/src/soap.lisp
by scaekenberghe＠common-lisp.net 19 Sep '05

19 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv21091/src Modified Files: soap.lisp Log Message: added return header parsing to soap-call Date: Mon Sep 19 18:56:13 2005 Author: scaekenberghe Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.5 cl-soap/src/soap.lisp:1.6 --- cl-soap/src/soap.lisp:1.5 Mon Sep 12 16:28:39 2005 +++ cl-soap/src/soap.lisp Mon Sep 19 18:56:13 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.5 2005/09/12 14:28:39 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.6 2005/09/19 16:56:13 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -115,14 +115,16 @@ (when *debug-stream* (setf *last-soap-result-xml* result-soap-envelope)) (if (eql (lxml-get-tag result-soap-envelope) 'soapenv:|Envelope|) - ;; we ignore returned headers for now - ;; only the first child of the body is returned, unless it is a fault - (let ((body (lxml-find-tag 'soapenv:|Body| (rest result-soap-envelope)))) + (let ((headers (lxml-find-tag 'soapenv:|Header| (rest result-soap-envelope))) + (body (lxml-find-tag 'soapenv:|Body| (rest result-soap-envelope)))) + ;; simply return header key/value pairs as an alist + (setf headers (mapcar #'(lambda (x) (cons (lxml-get-tag x) (second x))) (rest headers))) + ;; only the first child of the body is returned, unless it is a fault (if body (let ((fault (lxml-find-tag 'soapenv:|Fault| (rest body)))) (if fault (error (lxml->standard-soap-fault fault)) - (second body))) + (values (second body) headers))) (error "No body found in SOAP Envelope"))) (error "No SOAP Envelope found"))))

1 0

[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 19 Sep '05

19 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv18986/src Modified Files: xsd.lisp Log Message: 1st implementation of date,time&datetime conversions Date: Mon Sep 19 18:27:04 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.2 cl-soap/src/xsd.lisp:1.3 --- cl-soap/src/xsd.lisp:1.2 Fri Sep 16 09:51:15 2005 +++ cl-soap/src/xsd.lisp Mon Sep 19 18:27:04 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.2 2005/09/16 07:51:15 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.3 2005/09/19 16:27:04 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -118,9 +118,115 @@ (defun intern-xsd-type-name (name) (intern (string-upcase (actual-name name)) :keyword)) +;;; Date, Time and DateTime conversions + +(defvar *xsd-timezone* nil) + +(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) + (if *xsd-timezone* + (decode-universal-time universal-time *xsd-timezone*) + (decode-universal-time universal-time)) + (declare (ignore day daylight-p)) + (let ((sign (if (minusp timezone) #\- #\+)) + (timezone-hour (floor (* (abs timezone) 60) 60)) + (timezone-minute (rem (* (abs timezone) 60) 60))) + (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d.000~c~2,'0d:~2,'0d" + year month date hour minute second sign timezone-hour timezone-minute)))) + +(defun xsd-datetime->lisp (string) + "1999-05-31T13:20:00.000-05:00" + (let* ((contains-millis (position #\. string)) + (contains-timezone (or (position #\: string :start 18) (position #\Z string))) + (year (parse-integer string :start 0 :end 4)) + (month (parse-integer string :start 5 :end 7)) + (date (parse-integer string :start 8 :end 10)) + (hour (parse-integer string :start 11 :end 13)) + (minute (parse-integer string :start 14 :end 16)) + (second (parse-integer string :start 17 :end 19)) + timezone-sign + timezone-hour + timezone-minute) + (when contains-timezone + (if (position #\Z string) + (setf timezone-sign 1 + timezone-hour 0 + timezone-minute 0) + (if contains-millis + (setf timezone-sign (ecase (char string 23) (#\- -1) (#\+ +1)) + timezone-hour (parse-integer string :start 24 :end 26) + timezone-minute (parse-integer string :start 27 :end 29)) + (setf timezone-sign (ecase (char string 19) (#\- -1) (#\+ +1)) + timezone-hour (parse-integer string :start 20 :end 22) + timezone-minute (parse-integer string :start 23 :end 25))))) + (if (or *xsd-timezone* contains-timezone) + (encode-universal-time second minute hour date month year + (if contains-timezone + (* timezone-sign (+ timezone-hour (/ timezone-minute 60))) + *xsd-timezone*)) + (encode-universal-time second minute hour date month year)))) + +(defun lisp->xsd-date (universal-time) + "1999-05-31" + (multiple-value-bind (second minute hour date month year) + (if *xsd-timezone* + (decode-universal-time universal-time *xsd-timezone*) + (decode-universal-time universal-time)) + (declare (ignore second minute hour)) + (format nil "~4,'0d-~2,'0d-~2,'0d" year month date))) + +(defun xsd-date->lisp (string) + "1999-05-31" + (let ((year (parse-integer string :start 0 :end 4)) + (month (parse-integer string :start 5 :end 7)) + (date (parse-integer string :start 8 :end 10))) + (if *xsd-timezone* + (encode-universal-time 0 0 0 date month year *xsd-timezone*) + (encode-universal-time 0 0 0 date month year)))) + +(defun lisp->xsd-time (universal-time) + "13:20:00.000-05:00" + (multiple-value-bind (second minute hour date month year day daylight-p timezone) + (if *xsd-timezone* + (decode-universal-time universal-time *xsd-timezone*) + (decode-universal-time universal-time)) + (declare (ignore year month date day daylight-p)) + (let ((sign (if (minusp timezone) #\- #\+)) + (timezone-hour (floor (* (abs timezone) 60) 60)) + (timezone-minute (rem (* (abs timezone) 60) 60))) + (format nil "~2,'0d:~2,'0d:~2,'0d.000~c~2,'0d:~2,'0d" + hour minute second sign timezone-hour timezone-minute)))) + +(defun xsd-time->lisp (string) + "13:20:00.000-05:00" + (let* ((contains-millis (position #\. string)) + (contains-timezone (position #\: string :start 7)) + (hour (parse-integer string :start 0 :end 2)) + (minute (parse-integer string :start 3 :end 5)) + (second (parse-integer string :start 6 :end 8)) + timezone-sign + timezone-hour + timezone-minute) + (when contains-timezone + (if contains-millis + (setf timezone-sign (ecase (char string 12) (#\- -1) (#\+ +1)) + timezone-hour (parse-integer string :start 13 :end 15) + timezone-minute (parse-integer string :start 16 :end 18)) + (setf timezone-sign (ecase (char string 8) (#\- -1) (#\+ +1)) + timezone-hour (parse-integer string :start 9 :end 11) + timezone-minute (parse-integer string :start 12 :end 14)))) + (if (or *xsd-timezone* contains-timezone) + (encode-universal-time second minute hour 1 1 0 + (if contains-timezone + (* timezone-sign (+ timezone-hour (/ timezone-minute 60))) + *xsd-timezone*)) + (encode-universal-time second minute hour 1 1 0)))) + +;;; Primitive Types/Values Conversions + (defun xsd-primitive->lisp (value type) "Convert the XSD string value to a Common Lisp value, interpreting it as type" - ;; more work needed here ;-) (ecase type ((:string :normalizedString :token) value) @@ -140,15 +246,14 @@ ((string-equal value "false") nil) (t (= (parse-integer value) 1)))) (:duration value) - (:date value) - (:time value) - (:dateTime value) + (:date (xsd-date->lisp value)) + (:time (xsd-time->lisp value)) + (:dateTime (xsd-datetime->lisp value)) ((:base64Binary :hexBinary) (error "~a not yet supported as primitive type" type)))) (defun lisp->xsd-primitive (value type) "Convert the Common Lisp value to a XSD string value, interpreting it as type" - ;; more work needed here ;-) (ecase type ((:string :normalizedString :token) value) @@ -166,9 +271,9 @@ (:boolean (if value "true" "false")) (:duration value) - (:date value) - (:time value) - (:dateTime value) + (:date (lisp->xsd-date value)) + (:time (lisp->xsd-time value)) + (:dateTime (lisp->xsd-datetime value)) ((:base64Binary :hexBinary) (error "~a not yet supported as primitive type" type))))

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 16 Sep '05

16 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv24768/test Modified Files: test-google-adwords.lisp Log Message: 1st actual (manual) google adwords api call Date: Fri Sep 16 14:54:36 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.1 cl-soap/test/test-google-adwords.lisp:1.2 --- cl-soap/test/test-google-adwords.lisp:1.1 Thu Sep 15 15:34:45 2005 +++ cl-soap/test/test-google-adwords.lisp Fri Sep 16 14:54:36 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.1 2005/09/15 13:34:45 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.2 2005/09/16 12:54:36 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -13,6 +13,28 @@ (in-package :cl-soap) +;;; account parameters + +(defvar *google-adwords-email*) +(defvar *google-adwords-password*) +(defvar *google-adwords-user-agent) +(defvar *google-adwords-token*) + +;;; constants + +(defconstant +google-adwords-ns-uri+ "https://adwords.google.com/api/adwords/v2") + +(defpackage :google + (:nicknames "google") + (:export + ;; headers + "email" "password" "useragent" "token" + ;; info service + "getUsageQuotaThisMonth" "getUsageQuotaThisMonthResponse" "getUsageQuotaThisMonthReturn") + (:documentation "Package for symbols in the Google Adwords API XML Namespace")) + +(defparameter *google-adwords-ns* (s-xml:register-namespace +google-adwords-ns-uri+ "google" :google)) + ;;; basic WSDL parsing (defparameter *google-adwords-api-wsdl-urls* @@ -29,4 +51,32 @@ (defun parse-all-wsdl () (mapcar #'parse-wsdl-url *google-adwords-api-wsdl-urls*)) +;;; manual calls + +(defun getUsageQuotaThisMonth () + (let* ((xmethods (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService")) + (result (soap-call xmethods + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*)) + `(google:|getUsageQuotaThisMonth|) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)))) + (if (eql (lxml-get-tag result) 'google:|getUsageQuotaThisMonthResponse|) + (let ((contents (lxml-find-tag 'google:|getUsageQuotaThisMonthReturn| (rest result)))) + (if contents + (coerce (parse-integer (second contents)) 'integer) + (error "Expected a <getUsageQuotaThisMonthReturn> element"))) + (error "Expected a <getUsageQuotaThisMonthResponse> element")))) + +#+NIL +(defun getUsageQuotaThisMonth () + ;; when we can handle the google type schema this will work ;-) + (wsdl-soap-call "https://adwords.google.com:443/api/adwords/v2/InfoService" + "getUsageQuotaThisMonth" + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token*))) + ;;;; eof

1 0

[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp
by scaekenberghe＠common-lisp.net 16 Sep '05

16 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv24768/src Modified Files: wsdl.lisp Log Message: 1st actual (manual) google adwords api call Date: Fri Sep 16 14:54:35 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.7 cl-soap/src/wsdl.lisp:1.8 --- cl-soap/src/wsdl.lisp:1.7 Fri Sep 16 09:51:15 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 16 14:54:34 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.7 2005/09/16 07:51:15 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.8 2005/09/16 12:54:34 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -386,9 +386,10 @@ service-name port-name input - output) - "Use WSDL to make a SOAP call of operation/port/service using input/output" - (declare (ignore output)) + output + headers) + "Use WSDL to make a SOAP call of operation/port/service using input/output/headers" + (declare (ignore output headers)) (let* ((wsdl-document-definitions (etypecase wsdl (wsdl-document-definitions wsdl) (string (parse-wsdl-url wsdl))

1 0

[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 16 Sep '05

16 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv3468/src Modified Files: lxml.lisp wsdl.lisp xsd.lisp Log Message: basic integration of xsd primitive type handling in wsdl-soap-call Date: Fri Sep 16 09:51:15 2005 Author: scaekenberghe Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.4 cl-soap/src/lxml.lisp:1.5 --- cl-soap/src/lxml.lisp:1.4 Thu Sep 15 15:32:32 2005 +++ cl-soap/src/lxml.lisp Fri Sep 16 09:51:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.4 2005/09/15 13:32:32 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.5 2005/09/16 07:51:15 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -13,6 +13,8 @@ (in-package :cl-soap) +;;; external + (defun lxml-get-tag (lxml) "Return the XML tag symbol of the lxml XML DOM" (cond ((symbolp lxml) lxml) @@ -28,5 +30,14 @@ (defun lxml-find-tag (tag lxml) "Find a specific tag in a lxml XML DOM list" (find tag lxml :key #'lxml-get-tag)) + +;;; internal + +(defun actual-name (qname) + "For now we ignore prefixes ;-)" + (multiple-value-bind (prefix identifier) + (s-xml:split-identifier qname) + (declare (ignore prefix)) + identifier)) ;;;; eof Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.6 cl-soap/src/wsdl.lisp:1.7 --- cl-soap/src/wsdl.lisp:1.6 Thu Sep 15 15:37:34 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 16 09:51:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.7 2005/09/16 07:51:15 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -303,13 +303,6 @@ ;; Interpreting the WSDL model -(defun actual-name (qname) - "For now we ignore prefixes ;-)" - (multiple-value-bind (prefix identifier) - (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)) @@ -436,12 +429,16 @@ (s-xml:register-namespace input-namespace-uri "ns1" :ns1) (error "The case where input and output namespaces differ is not yet supported")) (loop :for part :in (get-parts input-message) :do - (let* ((value (second (member (get-name part) input :test #'equal)))) + (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)) - ,(princ-to-string value)) - actual-input-parameters) + ;; 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* ((input-wrapper (intern (get-name binding-operation) :ns1)) (result (soap-call soap-end-point @@ -456,10 +453,17 @@ (if (eql (lxml-get-tag result) output-wrapper) (progn (loop :for part :in (get-parts output-message) :do - (let ((part-element (lxml-find-tag (intern (get-name part) :keyword) (rest result)))) - ;; add type conversions ;-) - (push (rest part-element) result-values))) - (nreverse result-values)) + (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)))) + (if (= (length result-values) 1) + (first result-values) + (nreverse result-values))) (error "Expected <~a> element" output-wrapper)))) (error "Only standard SOAP RPC style currently supported as binding")) (error "Only standard SOAP HTTP transport currently supported as binding")))) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.1 cl-soap/src/xsd.lisp:1.2 --- cl-soap/src/xsd.lisp:1.1 Thu Sep 15 15:37:34 2005 +++ cl-soap/src/xsd.lisp Fri Sep 16 09:51:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.1 2005/09/15 13:37:34 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.2 2005/09/16 07:51:15 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -97,14 +97,79 @@ ;;; Interpreting the XSD model -;;; Primitive Types/Values +;;; Primitive Types/Values (types are keywords) + +(defconstant +known-primitive-type-names+ + '("string" + "normalizedString" "token" + "Name" "QName" "NCName" "anyURI" + "integer" + "positiveInteger" "negativeInteger" "nonPositiveInteger" "nonNegativeInteger" + "long" "unsignedLong" "int" "unsignedInt" "short" "unsignedShort" + "byte" "decimal" + "float" "double" + "boolean" + "duration" "date" "time" "dateTime" + "base64Binary" "hexBinary")) + +(defun xsd-primitive-type-name-p (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)) (defun xsd-primitive->lisp (value type) - (declare (ignore type)) - value) + "Convert the XSD string value to a Common Lisp value, interpreting it as type" + ;; more work needed here ;-) + (ecase type + ((:string :normalizedString :token) + value) + ((:Name :QName :NCName :anyURI) + value) + ((:integer + :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger + :long :unsignedLong :int :unsignedInt :short :unsignedShort + :byte :decimal) + (parse-integer value) 'integer) + (:float + (coerce (read-from-string value) 'float)) + (:double + (coerce (read-from-string value) 'double)) + (:boolean + (cond ((string-equal value "true") t) + ((string-equal value "false") nil) + (t (= (parse-integer value) 1)))) + (:duration value) + (:date value) + (:time value) + (:dateTime value) + ((:base64Binary :hexBinary) + (error "~a not yet supported as primitive type" type)))) (defun lisp->xsd-primitive (value type) - (declare (ignore type)) - value) + "Convert the Common Lisp value to a XSD string value, interpreting it as type" + ;; more work needed here ;-) + (ecase type + ((:string :normalizedString :token) + value) + ((:Name :QName :NCName :anyURI) + value) + ((:integer + :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger + :long :unsignedLong :int :unsignedInt :short :unsignedShort + :byte :decimal) + (princ-to-string value)) + (:float + (princ-to-string value)) + (:double + (princ-to-string value)) + (:boolean + (if value "true" "false")) + (:duration value) + (:date value) + (:time value) + (:dateTime value) + ((:base64Binary :hexBinary) + (error "~a not yet supported as primitive type" type)))) ;;;; eof

1 0

[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp cl-soap/src/namespaces.lisp cl-soap/src/wsdl.lisp
by scaekenberghe＠common-lisp.net 15 Sep '05

15 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23928/src Modified Files: namespaces.lisp wsdl.lisp Added Files: xsd.lisp Log Message: added first step towards partial XML Schema Definition implmentation to support WSDL types schema Date: Thu Sep 15 15:37:35 2005 Author: scaekenberghe Index: cl-soap/src/namespaces.lisp diff -u cl-soap/src/namespaces.lisp:1.5 cl-soap/src/namespaces.lisp:1.6 --- cl-soap/src/namespaces.lisp:1.5 Mon Sep 12 13:24:01 2005 +++ cl-soap/src/namespaces.lisp Thu Sep 15 15:37:34 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: namespaces.lisp,v 1.5 2005/09/12 11:24:01 scaekenberghe Exp $ +;;;; $Id: namespaces.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $ ;;;; ;;;; Definition of some standard XML namespaces commonly needed for SOAP ;;;; @@ -32,7 +32,9 @@ (defpackage :xsd (:nicknames "xsd") - (:export) + (:export "schema" "element" "simpleType" "complexType" + "sequence" "choice" "all" "attribute" + "restriction" "maxLength" "pattern" "list" "union" "enumeration") (:documentation "Package for symbols in the XML Schema Definition XML Namespace")) (defparameter *xsd-ns* (s-xml:register-namespace +xsd-ns-uri+ "xsd" :xsd)) Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.5 cl-soap/src/wsdl.lisp:1.6 --- cl-soap/src/wsdl.lisp:1.5 Tue Sep 13 21:23:48 2005 +++ cl-soap/src/wsdl.lisp Thu Sep 15 15:37:34 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.5 2005/09/13 19:23:48 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -79,10 +79,6 @@ (defclass wsdl-message (abstract-wsdl-definition) ((parts :accessor get-parts :initarg :parts :initform nil))) -(defclass wsdl-type (abstract-wsdl-definition) - ;; to be finished !!! - ((data-type-definitions))) - ;;; WSDL SOAP Model Extension Elements (defclass wsdl-soap-address () @@ -122,6 +118,13 @@ ;; one day we should handle <import> statements ;-) +(defun lxml->types (lxml) + (let (types) + (loop :for element :in (rest lxml) :do + (if (eql (lxml-get-tag element) 'xsd:|schema|) + (push (lxml->schema-definition element) types))) + types)) + (defun lxml->operation-element (lxml) (let* ((attributes (lxml-get-attributes lxml)) (message (getf attributes :|message|)) @@ -247,7 +250,8 @@ (rest element))) (wsdl-soap:|address| (setf (get-extension wsdl-port) (make-instance 'wsdl-soap-address - :location (getf (lxml-get-attributes element) :|location|)))))) + :location (getf (lxml-get-attributes element) + :|location|)))))) wsdl-port)) (defun lxml->service (lxml) @@ -275,7 +279,8 @@ :do (case (lxml-get-tag element) (wsdl:|documentation| (setf (get-documentation wsdl-document-definitions) (rest element))) - (wsdl:|types|) + (wsdl:|types| (setf (get-types wsdl-document-definitions) + (lxml->types element))) (wsdl:|message| (push (lxml->message element) (get-messages wsdl-document-definitions))) (wsdl:|portType| (push (lxml->port-type element)

1 0

[cl-soap-cvs] CVS update: cl-soap/cl-soap.asd
by scaekenberghe＠common-lisp.net 15 Sep '05

15 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap In directory common-lisp.net:/tmp/cvs-serv23928 Modified Files: cl-soap.asd Log Message: added first step towards partial XML Schema Definition implmentation to support WSDL types schema Date: Thu Sep 15 15:37:34 2005 Author: scaekenberghe Index: cl-soap/cl-soap.asd diff -u cl-soap/cl-soap.asd:1.1 cl-soap/cl-soap.asd:1.2 --- cl-soap/cl-soap.asd:1.1 Mon Sep 5 10:35:53 2005 +++ cl-soap/cl-soap.asd Thu Sep 15 15:37:33 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: cl-soap.asd,v 1.1 2005/09/05 08:35:53 scaekenberghe Exp $ +;;;; $Id: cl-soap.asd,v 1.2 2005/09/15 13:37:33 scaekenberghe Exp $ ;;;; ;;;; The CL-SOAP ASDF system definition ;;;; @@ -28,7 +28,8 @@ (:file "http-client" :depends-on ("package")) (:file "lxml" :depends-on ("package")) (:file "namespaces" :depends-on ("package")) - (:file "soap" :depends-on ("package" "http-client" "namespaces" "lxml")) + (:file "xsd" :depends-on ("package" "namespaces" "lxml")) + (:file "soap" :depends-on ("package" "xsd" "http-client" "namespaces" "lxml")) (:file "wsdl" :depends-on ("package"))))) :depends-on (:s-xml :puri))

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp
by scaekenberghe＠common-lisp.net 15 Sep '05

15 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv23904/test Added Files: test-google-adwords.lisp Log Message: newly created; google adwords specific tests testing parsing of all wsdl file Date: Thu Sep 15 15:34:45 2005 Author: scaekenberghe

1 0

[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp
by scaekenberghe＠common-lisp.net 15 Sep '05

15 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23865/src Modified Files: lxml.lisp Log Message: added comments Date: Thu Sep 15 15:32:32 2005 Author: scaekenberghe Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.3 cl-soap/src/lxml.lisp:1.4 --- cl-soap/src/lxml.lisp:1.3 Sat Sep 10 21:55:19 2005 +++ cl-soap/src/lxml.lisp Thu Sep 15 15:32:32 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.3 2005/09/10 19:55:19 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.4 2005/09/15 13:32:32 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -14,16 +14,19 @@ (in-package :cl-soap) (defun lxml-get-tag (lxml) + "Return the XML tag symbol of the lxml XML DOM" (cond ((symbolp lxml) lxml) ((stringp lxml) '()) ((symbolp (first lxml)) (first lxml)) (t (first (first lxml))))) (defun lxml-get-attributes (lxml) + "Return the XML attributes plist of the lxml XML DOM" (cond ((or (symbolp lxml) (stringp lxml) (symbolp (first lxml))) '()) (t (rest (first lxml))))) (defun lxml-find-tag (tag lxml) - (find tag lxml :key #'lxml-get-tag)) + "Find a specific tag in a lxml XML DOM list" + (find tag lxml :key #'lxml-get-tag)) ;;;; eof

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cl-soap-cvs