September 2005 - cl-soap-cvs@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/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