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