From scaekenberghe at common-lisp.net Mon Sep 5 07:07:09 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 5 Sep 2005 09:07:09 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: public_html/index.html Message-ID: <20050905070709.8514988542@common-lisp.net> Update of /project/cl-soap/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv7679 Added Files: index.html Log Message: newly added from project proposal Date: Mon Sep 5 09:07:09 2005 Author: scaekenberghe From scaekenberghe at common-lisp.net Mon Sep 5 08:03:13 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 5 Sep 2005 10:03:13 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: public_html/index.html Message-ID: <20050905080313.63EF58815C@common-lisp.net> Update of /project/cl-soap/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv12122 Modified Files: index.html Log Message: added some progress report info Date: Mon Sep 5 10:03:12 2005 Author: scaekenberghe Index: public_html/index.html diff -u public_html/index.html:1.1 public_html/index.html:1.2 --- public_html/index.html:1.1 Mon Sep 5 09:07:08 2005 +++ public_html/index.html Mon Sep 5 10:03:12 2005 @@ -16,7 +16,18 @@

Phase 1 (First Delivery Target)

Setup of a public open source project (e.g. on common-lisp.net ).
Setup of a public open source project (on common-lisp.net ). +
- The official project home is + http://common-lisp.net/project/cl-soap
- The CVS repository can be found at + http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=cl-soap
- The following mailing list are available: + CL-SOAP-DEVEL + as well as + CL-SOAP-CVS
+
Implement as much of the general CL-SOAP framework to access the Google AdWords API ( http://www.google.com/apis/adwords/ ) from LispWorks ( http://www.lispworks.com ).

Technical Notes

-This project will depend on an XML parser - either the S-XML parser -( http://common-lisp.net/project/s-xml) needs to be extended -to support some necessary features (namespaces, I8N encodings, CDATA support), or another -open-source XML parser has to be selected. +This project depends on an XML parser. The S-XML parser +( http://common-lisp.net/project/s-xml) +has been extended to support some necessary features (namespaces for now). +The code for these additions to S-XML has not yet been released, +and is only available in the CVS repository. +Some documentation of the XML Namespace feature in S-XML can be found in +this mailing list message.

HTTP client and server code will be abstracted out and be made pluggable as to avoid unnecessary dependencies on other (larger) projects. +For now, a simple HTTP client has been added to the source code.

Organizational Notes

@@ -65,6 +80,6 @@ Initial developers and contributors will include Sven Van Caekenberghe (Beta Nine), Alain Picard (Memetrics), Ivan Melotte (Beta Nine) and Nicky Peeters (Beta Nine).

$Id: index.html,v 1.1 2005/09/05 07:07:08 scaekenberghe Exp $

$Id: index.html,v 1.2 2005/09/05 08:03:12 scaekenberghe Exp $

element")))) + +(defun parse-wsdl-file (pathname) + (with-open-file (in pathname) + (parse-wsdl in))) + +(defun parse-wsdl-url (url) + (let ((buffer (do-http-request url))) + (with-input-from-string (in buffer) + (parse-wsdl in)))) ;;;; eof From scaekenberghe at common-lisp.net Fri Sep 9 14:18:03 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 9 Sep 2005 16:18:03 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/namespaces.lisp Message-ID: <20050909141803.3EA70880DA@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv1240/src Modified Files: namespaces.lisp Log Message: more exports Date: Fri Sep 9 16:18:02 2005 Author: scaekenberghe Index: cl-soap/src/namespaces.lisp diff -u cl-soap/src/namespaces.lisp:1.3 cl-soap/src/namespaces.lisp:1.4 --- cl-soap/src/namespaces.lisp:1.3 Fri Sep 9 16:17:37 2005 +++ cl-soap/src/namespaces.lisp Fri Sep 9 16:18:02 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: namespaces.lisp,v 1.3 2005/09/09 14:17:37 scaekenberghe Exp $ +;;;; $Id: namespaces.lisp,v 1.4 2005/09/09 14:18:02 scaekenberghe Exp $ ;;;; ;;;; Definition of some standard XML namespaces commonly needed for SOAP ;;;; @@ -62,7 +62,7 @@ (:nicknames "wsdl") (:export "definitions" "documentation" - "portType" "message" "operation" "port" "service" "binding" "part" "input" "output" "fault") + "portType" "message" "operation" "port" "service" "binding" "part" "input" "output" "fault" "types") (:documentation "Package for symbols in the WSDL XML Namespace")) (defparameter *wsdl-ns* (s-xml:register-namespace +wsdl-ns-uri+ "wsdl" :wsdl)) From scaekenberghe at common-lisp.net Fri Sep 9 19:30:34 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 9 Sep 2005 21:30:34 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: public_html/index.html Message-ID: <20050909193034.1F3628854B@common-lisp.net> Update of /project/cl-soap/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv21978 Modified Files: index.html Log Message: added cvs instructions Date: Fri Sep 9 21:30:14 2005 Author: scaekenberghe Index: public_html/index.html diff -u public_html/index.html:1.2 public_html/index.html:1.3 --- public_html/index.html:1.2 Mon Sep 5 10:03:12 2005 +++ public_html/index.html Fri Sep 9 21:30:14 2005 @@ -18,10 +18,19 @@

Setup of a public open source project (on common-lisp.net ).
- The official project home is +
- The official project home is http://common-lisp.net/project/cl-soap
- The CVS repository can be found at http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=cl-soap
- To get the code through CVS: +
```
$ cvs -d:pserver:anonymous at common-lisp.net:/project/cl-soap/cvsroot login
+Logging in to :pserver:anonymous at common-lisp.net:2401/project/cl-soap/cvsroot
+CVS password:
+$ cvs -d:pserver:anonymous at common-lisp.net:/project/cl-soap/cvsroot co cl-soap
+cvs server: Updating cl-soap
+...
```
  + Specifiy 'anonymous' as password. Afterwards, keep up to date by issuing cvs update in the cl-soap directory. +
- The following mailing list are available: CL-SOAP-DEVEL as well as @@ -80,6 +89,6 @@ Initial developers and contributors will include Sven Van Caekenberghe (Beta Nine), Alain Picard (Memetrics), Ivan Melotte (Beta Nine) and Nicky Peeters (Beta Nine).
  -
  $Id: index.html,v 1.2 2005/09/05 08:03:12 scaekenberghe Exp $
  +
  $Id: index.html,v 1.3 2005/09/09 19:30:14 scaekenberghe Exp $
  From scaekenberghe at common-lisp.net Sat Sep 10 19:55:20 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Sat, 10 Sep 2005 21:55:20 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp Message-ID: <20050910195520.21D8888537@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv29873/src Modified Files: lxml.lisp Log Message: single symbols are also lxml Date: Sat Sep 10 21:55:19 2005 Author: scaekenberghe Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.2 cl-soap/src/lxml.lisp:1.3 --- cl-soap/src/lxml.lisp:1.2 Fri Sep 9 16:17:37 2005 +++ cl-soap/src/lxml.lisp Sat Sep 10 21:55:19 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.2 2005/09/09 14:17:37 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.3 2005/09/10 19:55:19 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -14,14 +14,14 @@ (in-package :cl-soap) (defun lxml-get-tag (lxml) - (if (symbolp (first lxml)) - (first lxml) - (first (first lxml)))) + (cond ((symbolp lxml) lxml) + ((stringp lxml) '()) + ((symbolp (first lxml)) (first lxml)) + (t (first (first lxml))))) (defun lxml-get-attributes (lxml) - (if (symbolp (first lxml)) - '() - (rest (first lxml)))) + (cond ((or (symbolp lxml) (stringp lxml) (symbolp (first lxml))) '()) + (t (rest (first lxml))))) (defun lxml-find-tag (tag lxml) (find tag lxml :key #'lxml-get-tag)) From scaekenberghe at common-lisp.net Sat Sep 10 19:56:29 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Sat, 10 Sep 2005 21:56:29 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-basic.lisp Message-ID: <20050910195629.3F65D88537@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv29909/test Modified Files: test-basic.lisp Log Message: added the random.org example (contributed by carlos.ungil at bluewin.ch) Date: Sat Sep 10 21:56:28 2005 Author: scaekenberghe Index: cl-soap/test/test-basic.lisp diff -u cl-soap/test/test-basic.lisp:1.2 cl-soap/test/test-basic.lisp:1.3 --- cl-soap/test/test-basic.lisp:1.2 Thu Sep 8 17:39:46 2005 +++ cl-soap/test/test-basic.lisp Sat Sep 10 21:56:28 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-basic.lisp,v 1.2 2005/09/08 15:39:46 scaekenberghe Exp $ +;;;; $Id: test-basic.lisp,v 1.3 2005/09/10 19:56:28 scaekenberghe Exp $ ;;;; ;;;; Some test for the basic SOAP protocol ;;;; @@ -76,6 +76,26 @@ (coerce (read-from-string (second contents)) 'float) (error "Expected a element"))) (error "Expected a element"))))) + +;; contributed by carlos.ungil at bluewin.ch +;; http://www.random.org/soap.html +;; http://www.random.org/RandomDotOrg.wsdl +;; http://www.random.org/clients/soap/ + +(defun get-random-number (&key unsigned) + "Returns a true random number in the interval [2^31, 2^31) or [0, 2^31)" + (let ((ns "urn:RandomDotOrg")) + (s-xml:register-namespace ns "ns1" :ns1) + (let* ((rng (make-soap-end-point "http://www.random.org/cgi-bin/Random.cgi")) + (result (soap-call rng + nil + (if unsigned + `((ns1::|lrand48| :|xmlns:ns1| ,ns)) + `((ns1::|mrand48| :|xmlns:ns1| ,ns)))))) + (if (or (eql (lxml-get-tag result) 'ns1::|lrand48Response|) + (eql (lxml-get-tag result) 'ns1::|mrand48Response|)) + (values (parse-integer (second (second result)))) + (error "Expected a or element"))))) ;; accessing local AXIS services From scaekenberghe at common-lisp.net Sat Sep 10 19:57:51 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Sat, 10 Sep 2005 21:57:51 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/soap.lisp Message-ID: <20050910195751.28A5A88537@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv29935/src Modified Files: soap.lisp Log Message: making clear that we only handle a single soap body elementCVS: ---------------------------------------------------------------------- Date: Sat Sep 10 21:57:50 2005 Author: scaekenberghe Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.3 cl-soap/src/soap.lisp:1.4 --- cl-soap/src/soap.lisp:1.3 Fri Sep 9 13:21:16 2005 +++ cl-soap/src/soap.lisp Sat Sep 10 21:57:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.3 2005/09/09 11:21:16 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.4 2005/09/10 19:57:50 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -79,8 +79,16 @@ ;;; Call Interface -(defun soap-call (server-end-point header body &key soap-action envelope-attributes header-attributes body-attributes) +(defun soap-call (server-end-point + header + body + &key + soap-action + envelope-attributes + header-attributes + body-attributes) "Make a SOAP Call to server-end-point using headers and body" + ;; only one single body element is allowed/supported for now (let* ((call-soap-envelope (soap-envelope header body :envelope-attributes envelope-attributes :header-attributes header-attributes From scaekenberghe at common-lisp.net Mon Sep 12 11:24:02 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 12 Sep 2005 13:24:02 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/namespaces.lisp cl-soap/src/wsdl.lisp Message-ID: <20050912112402.C422488544@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv30908/src Modified Files: namespaces.lisp wsdl.lisp Log Message: added parsing of WSDL SOAP extension elements Date: Mon Sep 12 13:24:01 2005 Author: scaekenberghe Index: cl-soap/src/namespaces.lisp diff -u cl-soap/src/namespaces.lisp:1.4 cl-soap/src/namespaces.lisp:1.5 --- cl-soap/src/namespaces.lisp:1.4 Fri Sep 9 16:18:02 2005 +++ cl-soap/src/namespaces.lisp Mon Sep 12 13:24:01 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: namespaces.lisp,v 1.4 2005/09/09 14:18:02 scaekenberghe Exp $ +;;;; $Id: namespaces.lisp,v 1.5 2005/09/12 11:24:01 scaekenberghe Exp $ ;;;; ;;;; Definition of some standard XML namespaces commonly needed for SOAP ;;;; @@ -73,7 +73,7 @@ (defpackage :wsdl-soap (:nicknames "wsdl-soap") - (:export) + (:export "address" "binding" "operation" "body" "header" "fault" "headerfault") (:documentation "Package for symbols in the WSDL Soap Bindings XML Namespace")) (defparameter *wsdl-soap-ns* (s-xml:register-namespace +wsdl-soap-ns-uri+ "soap" :wsdl-soap)) Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.2 cl-soap/src/wsdl.lisp:1.3 --- cl-soap/src/wsdl.lisp:1.2 Fri Sep 9 16:17:37 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 12 13:24:01 2005 @@ -1,8 +1,8 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.2 2005/09/09 14:17:37 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.3 2005/09/12 11:24:01 scaekenberghe Exp $ ;;;; -;;;; The basic WSDL protocol +;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; ;;;; Copyright (C) 2005 Sven Van Caekenberghe, Beta Nine BVBA. All Rights Reserved. ;;;; @@ -13,7 +13,7 @@ (in-package :cl-soap) -;;; Generic Soap Model +;;; Generic WSDL Model (defclass abstract-wsdl-definition () ((name :accessor get-name :initarg :name :initform nil) @@ -36,17 +36,19 @@ (defclass wsdl-port (abstract-wsdl-definition) ((binding :accessor get-binding :initarg :binding :initform nil) - (network-address))) + (extension :accessor get-extension :initarg :extension :initform nil))) (defclass wsdl-binding (abstract-wsdl-definition) ((type :accessor get-type :initarg :type :initform nil) - (operations :accessor get-operations :initarg :operations :initform nil))) + (operations :accessor get-operations :initarg :operations :initform nil) + (extensions :accessor get-extensions :initarg :extensions :initform nil))) (defclass wsdl-port-type (abstract-wsdl-definition) ((operations :accessor get-operations :initarg :operations :initform nil))) (defclass wsdl-operation-element () - ((message :accessor get-message :initarg :message :initform nil))) + ((message :accessor get-message :initarg :message :initform nil) + (extensions :accessor get-extensions :initarg :extensions :initform nil))) (defmethod print-object ((object wsdl-operation-element) out) (print-unreadable-object (object out :type t :identity t) @@ -62,7 +64,8 @@ ()) (defclass wsdl-operation (abstract-wsdl-definition) - ((elements :accessor get-elements :initarg :elements :initform nil))) + ((elements :accessor get-elements :initarg :elements :initform nil) + (extensions :accessor get-extensions :initarg :extensions :initform nil))) (defclass wsdl-part () ((name :accessor get-name :initarg :name :initform nil) @@ -77,60 +80,107 @@ ((parts :accessor get-parts :initarg :parts :initform nil))) (defclass wsdl-type (abstract-wsdl-definition) + ;; to be finished !!! ((data-type-definitions))) -;;; WSDL SOAP Model +;;; WSDL SOAP Model Extension Elements -(defclass wsdl-soap-service (wsdl-service) - ((location))) +(defclass wsdl-soap-address () + ((location :accessor get-location :initarg :location :initform "http://localhost"))) -(defclass wsdl-soap-binding (wsdl-binding) - ((style) - (transport))) - -(defclass wsdl-soap-operation (wsdl-operation) - ((soap-action) - (style))) - -(defclass wsdl-soap-body () - ((parts) - (use) - (encoding-style) - (namespace))) - -(defclass wsdl-soap-fault () - ((name) - (use) - (encoding-style) - (namespace))) - -(defclass wsdl-soap-header () - ((message) - (part) - (use) - (encoding-style) - (namespace))) +(defmethod print-object ((object wsdl-soap-address) out) + (print-unreadable-object (object out :type t :identity t) + (prin1 (or (get-location object) "unknown") out))) + +(defclass wsdl-soap-binding () + ((style :accessor get-style :initarg :style :initform "document") + (transport :accessor get-transport :initarg :transport :initform "http://schemas.xmlsoap.org/soap/http"))) + +(defclass wsdl-soap-operation () + ((soap-action :accessor get-soap-action :initarg :soap-action :initform nil) + (style :accessor get-style :initarg :style :initform nil))) + +(defclass wsdl-soap-operation-element () + ((use :accessor get-use :initarg :use :initform nil) + (encoding-style :accessor get-encoding-style :initarg :encoding-style :initform nil) + (namespace :accessor get-namespace :initarg :namespace :initform nil))) + +(defclass wsdl-soap-body (wsdl-soap-operation-element) + ((parts :accessor get-parts :initarg :parts :initform nil))) + +(defclass wsdl-soap-fault (wsdl-soap-operation-element) + ((name :accessor get-name :initarg :name :initform nil))) + +(defclass wsdl-soap-header (wsdl-soap-operation-element) + ((message :accessor get-message :initarg :message :initform nil) + (part :accessor get-part :initarg :part :initform nil))) (defclass wsdl-soap-header-fault (wsdl-soap-header) ()) ;; Parsing +;; one day we should handle statements ;-) + +(defun lxml->operation-element (lxml) + (let* ((attributes (lxml-get-attributes lxml)) + (message (getf attributes :|message|)) + (class (ecase (lxml-get-tag lxml) + (wsdl:|input| 'wsdl-input) + (wsdl:|output| 'wsdl-output) + (wsdl:|fault| 'wsdl-fault))) + (operation-element (make-instance class :message message))) + (loop :for element :in (rest lxml) + :do (case (lxml-get-tag element) + (wsdl:|documentation| (setf (get-documentation operation-element) + (rest element))) + (wsdl-soap:|body| (let ((attributes (lxml-get-attributes element))) + (push (make-instance 'wsdl-soap-body + :use (getf attributes :|use|) + :encoding-style (getf attributes :|encodingStyle|) + :namespace (getf attributes :|namespace|) + :parts (getf attributes :|parts|)) + (get-extensions operation-element)))) + (wsdl-soap:|fault| (let ((attributes (lxml-get-attributes element))) + (push (make-instance 'wsdl-soap-fault + :use (getf attributes :|use|) + :encoding-style (getf attributes :|encodingStyle|) + :namespace (getf attributes :|namespace|) + :name (getf attributes :|name|)) + (get-extensions operation-element)))) + (wsdl-soap:|header| (let ((attributes (lxml-get-attributes element))) + (push (make-instance 'wsdl-soap-header + :use (getf attributes :|use|) + :encoding-style (getf attributes :|encodingStyle|) + :namespace (getf attributes :|namespace|) + :part (getf attributes :|part|) + :message (getf attributes :|message|)) + (get-extensions operation-element)))) + (wsdl-soap:|headerfault| (let ((attributes (lxml-get-attributes element))) + (push (make-instance 'wsdl-soap-header-fault + :use (getf attributes :|use|) + :encoding-style (getf attributes :|encodingStyle|) + :namespace (getf attributes :|namespace|) + :part (getf attributes :|part|) + :message (getf attributes :|message|)) + (get-extensions operation-element)))))) + operation-element)) + (defun lxml->operation (lxml) (let* ((attributes (lxml-get-attributes lxml)) (name (getf attributes :|name|)) (wsdl-operation (make-instance 'wsdl-operation :name name))) (loop :for element :in (rest lxml) :do (case (lxml-get-tag element) - (wsdl:|input| (push (make-instance 'wsdl-input - :message (getf (lxml-get-attributes element) :|message|)) - (get-elements wsdl-operation))) - (wsdl:|output| (push (make-instance 'wsdl-output - :message (getf (lxml-get-attributes element) :|message|)) - (get-elements wsdl-operation))) - (wsdl:|fault| (push (make-instance 'wsdl-fault - :message (getf (lxml-get-attributes element) :|message|)) - (get-elements wsdl-operation))))) + (wsdl:|documentation| (setf (get-documentation wsdl-operation) + (rest element))) + (wsdl-soap:|operation| (let ((attributes (lxml-get-attributes element))) + (push (make-instance 'wsdl-soap-operation + :style (getf attributes :|style|) + :soap-action (getf attributes :|soapAction|)) + (get-extensions wsdl-operation)))) + ((wsdl:|input| wsdl:|output| wsdl:|fault|) (push (lxml->operation-element element) + (get-elements wsdl-operation))))) wsdl-operation)) (defun lxml->port-type (lxml) @@ -139,6 +189,8 @@ (wsdl-port-type (make-instance 'wsdl-port-type :name name))) (loop :for element :in (rest lxml) :do (case (lxml-get-tag element) + (wsdl:|documentation| (setf (get-documentation wsdl-port-type) + (rest element))) (wsdl:|operation| (push (lxml->operation element) (get-operations wsdl-port-type))))) wsdl-port-type)) @@ -160,6 +212,8 @@ (wsdl-message (make-instance 'wsdl-message :name name))) (loop :for element :in (rest lxml) :do (case (lxml-get-tag element) + (wsdl:|documentation| (setf (get-documentation wsdl-message) + (rest element))) (wsdl:|part| (push (lxml->part element) (get-parts wsdl-message))))) wsdl-message)) @@ -171,6 +225,13 @@ (wsdl-binding (make-instance 'wsdl-binding :name name :type type))) (loop :for element :in (rest lxml) :do (case (lxml-get-tag element) + (wsdl:|documentation| (setf (get-documentation wsdl-binding) + (rest element))) + (wsdl-soap:|binding| (let ((attributes (lxml-get-attributes element))) + (push (make-instance 'wsdl-soap-binding + :style (getf attributes :|style|) + :transport (getf attributes :|transport|)) + (get-extensions wsdl-binding)))) (wsdl:|operation| (push (lxml->operation element) (get-operations wsdl-binding))))) wsdl-binding)) @@ -180,6 +241,13 @@ (name (getf attributes :|name|)) (binding (getf attributes :|binding|)) (wsdl-port (make-instance 'wsdl-port :name name :binding binding))) + (loop :for element :in (rest lxml) + :do (case (lxml-get-tag element) + (wsdl:|documentation| (setf (get-documentation wsdl-port) + (rest element))) + (wsdl-soap:|address| (setf (get-extension wsdl-port) + (make-instance 'wsdl-soap-address + :location (getf (lxml-get-attributes element) :|location|)))))) wsdl-port)) (defun lxml->service (lxml) @@ -188,6 +256,8 @@ (wsdl-service (make-instance 'wsdl-service :name name))) (loop :for element :in (rest lxml) :do (case (lxml-get-tag element) + (wsdl:|documentation| (setf (get-documentation wsdl-service) + (rest element))) (wsdl:|port| (push (lxml->port element) (get-ports wsdl-service))))) wsdl-service)) From scaekenberghe at common-lisp.net Mon Sep 12 14:28:43 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 12 Sep 2005 16:28:43 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/soap.lisp cl-soap/src/wsdl.lisp Message-ID: <20050912142843.AEC1988544@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv11181/src Modified Files: soap.lisp wsdl.lisp Log Message: unimplemented API for making SOAP calls supported by WSDL Date: Mon Sep 12 16:28:40 2005 Author: scaekenberghe Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.4 cl-soap/src/soap.lisp:1.5 --- cl-soap/src/soap.lisp:1.4 Sat Sep 10 21:57:50 2005 +++ cl-soap/src/soap.lisp Mon Sep 12 16:28:39 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.4 2005/09/10 19:57:50 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.5 2005/09/12 14:28:39 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -79,6 +79,12 @@ ;;; Call Interface +(defvar *last-soap-call-xml* nil + "When *debug-stream* is non-nil, will contain the last SOAP call's parsed XML") + +(defvar *last-soap-result-xml* nil + "When *debug-stream* is non-nil, will contain the last SOAP result's parsed XML") + (defun soap-call (server-end-point header body @@ -96,6 +102,7 @@ (call-xml (s-xml:print-xml-string call-soap-envelope :pretty t)) result-xml result-soap-envelope) (when *debug-stream* + (setf *last-soap-call-xml* call-soap-envelope) (format *debug-stream* ";; SOAP CALL sending: ~a~%" call-xml)) (setf result-xml (do-http-request (get-url server-end-point) :method :POST @@ -105,6 +112,8 @@ (when *debug-stream* (format *debug-stream* ";; SOAP CALL receiving: ~a~%" result-xml)) (setf result-soap-envelope (s-xml:parse-xml-string result-xml)) + (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 Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.3 cl-soap/src/wsdl.lisp:1.4 --- cl-soap/src/wsdl.lisp:1.3 Mon Sep 12 13:24:01 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 12 16:28:40 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.3 2005/09/12 11:24:01 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.4 2005/09/12 14:28:40 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -295,5 +295,24 @@ (let ((buffer (do-http-request url))) (with-input-from-string (in buffer) (parse-wsdl in)))) + +;; Using WSDL to make structured SOAP calls + +(defun wsdl-soap-call (wsdl + operation-name + &key + service-name + port-name + input + output) + "Use WSDL to make a SOAP call of operation/port/service using input/output" + (declare (ignore wsdl operation-name service-name port-name input output)) + ;; 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) + ;; port-name: string of port of service to use (if nil, use first port found) + ;; input: plist ("name1" value1 "name2" value2) of actual parameters to use + ;; output: what to do with the result (if nil: use the contents of the first part of the output message, if possible) + t) ;;;; eof From scaekenberghe at common-lisp.net Mon Sep 12 14:28:43 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 12 Sep 2005 16:28:43 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-wsdl.lisp cl-soap/test/test-basic.lisp Message-ID: <20050912142843.E196B8855A@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv11181/test Modified Files: test-basic.lisp Added Files: test-wsdl.lisp Log Message: unimplemented API for making SOAP calls supported by WSDL Date: Mon Sep 12 16:28:41 2005 Author: scaekenberghe Index: cl-soap/test/test-basic.lisp diff -u cl-soap/test/test-basic.lisp:1.3 cl-soap/test/test-basic.lisp:1.4 --- cl-soap/test/test-basic.lisp:1.3 Sat Sep 10 21:56:28 2005 +++ cl-soap/test/test-basic.lisp Mon Sep 12 16:28:41 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-basic.lisp,v 1.3 2005/09/10 19:56:28 scaekenberghe Exp $ +;;;; $Id: test-basic.lisp,v 1.4 2005/09/12 14:28:41 scaekenberghe Exp $ ;;;; ;;;; Some test for the basic SOAP protocol ;;;; @@ -103,13 +103,13 @@ "Calling Axis's User Guide Example 3 'echo'" (let ((ns "http://example3.userguide.samples")) (s-xml:register-namespace ns "ns1" :ns1) - (let* ((local (make-soap-end-point "http://localhost:9090/axis/services/MyService")) + (let* ((local (make-soap-end-point "http://localhost:8080/axis/services/MyService")) (result (soap-call local '() `((ns1::|serviceMethod| soapenv:|encodingStyle| ,+soap-enc-ns-uri+ :|xmlns:ns1| ,ns) - ((:|arg2| xsi::|type| "xsd:string") + ((:|arg| xsi::|type| "xsd:string") ,string))))) (if (eql (lxml-get-tag result) 'ns1::|serviceMethodResponse|) (let ((contents (lxml-find-tag :|serviceMethodReturn| (rest result)))) From scaekenberghe at common-lisp.net Tue Sep 13 19:23:50 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 13 Sep 2005 21:23:50 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp Message-ID: <20050913192350.3149D880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv7414/src Modified Files: wsdl.lisp Log Message: added describe-wsdl-soap to print a human readable description of a wdsl-document-definition first, very limited, implementation of wsdl-soap-call (works in limited cases) Date: Tue Sep 13 21:23:49 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.4 cl-soap/src/wsdl.lisp:1.5 --- cl-soap/src/wsdl.lisp:1.4 Mon Sep 12 16:28:40 2005 +++ cl-soap/src/wsdl.lisp Tue Sep 13 21:23:48 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.4 2005/09/12 14:28:40 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.5 2005/09/13 19:23:48 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -38,17 +38,18 @@ ((binding :accessor get-binding :initarg :binding :initform nil) (extension :accessor get-extension :initarg :extension :initform nil))) -(defclass wsdl-binding (abstract-wsdl-definition) +(defclass wsdl-extensions-mixin () + ((extensions :accessor get-extensions :initarg :extensions :initform nil))) + +(defclass wsdl-binding (abstract-wsdl-definition wsdl-extensions-mixin) ((type :accessor get-type :initarg :type :initform nil) - (operations :accessor get-operations :initarg :operations :initform nil) - (extensions :accessor get-extensions :initarg :extensions :initform nil))) + (operations :accessor get-operations :initarg :operations :initform nil))) (defclass wsdl-port-type (abstract-wsdl-definition) ((operations :accessor get-operations :initarg :operations :initform nil))) -(defclass wsdl-operation-element () - ((message :accessor get-message :initarg :message :initform nil) - (extensions :accessor get-extensions :initarg :extensions :initform nil))) +(defclass wsdl-operation-element (wsdl-extensions-mixin) + ((message :accessor get-message :initarg :message :initform nil))) (defmethod print-object ((object wsdl-operation-element) out) (print-unreadable-object (object out :type t :identity t) @@ -63,9 +64,8 @@ (defclass wsdl-fault (wsdl-operation-element) ()) -(defclass wsdl-operation (abstract-wsdl-definition) - ((elements :accessor get-elements :initarg :elements :initform nil) - (extensions :accessor get-extensions :initarg :extensions :initform nil))) +(defclass wsdl-operation (abstract-wsdl-definition wsdl-extensions-mixin) + ((elements :accessor get-elements :initarg :elements :initform nil))) (defclass wsdl-part () ((name :accessor get-name :initarg :name :initform nil) @@ -296,8 +296,92 @@ (with-input-from-string (in buffer) (parse-wsdl in)))) +;; 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)) + +(defmethod get-service-named ((wsdl-document-definitions wsdl-document-definitions) service-name) + (find-item-named service-name (get-services wsdl-document-definitions))) + +(defmethod get-port-named ((wsdl-service wsdl-service) port-name) + (find-item-named port-name (get-ports wsdl-service))) + +(defmethod get-binding-named ((wsdl-document-definitions wsdl-document-definitions) binding-name) + (find-item-named binding-name (get-bindings wsdl-document-definitions))) + +(defmethod get-port-type-named ((wsdl-document-definitions wsdl-document-definitions) port-type-name) + (find-item-named port-type-name (get-port-types wsdl-document-definitions))) + +(defmethod get-message-named ((wsdl-document-definitions wsdl-document-definitions) message-name) + (find-item-named message-name (get-messages wsdl-document-definitions))) + +(defmethod get-operation-named ((wsdl-binding wsdl-binding) operation-name) + (find-item-named operation-name (get-operations wsdl-binding))) + +(defmethod get-operation-named ((wsdl-port-type wsdl-port-type) operation-name) + (find-item-named operation-name (get-operations wsdl-port-type))) + +(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))) + +(defmethod get-operation-element ((wsdl-operation wsdl-operation) operation-element-type) + (find-item-of-class operation-element-type (get-elements wsdl-operation))) + +(defmethod get-extension-of-class ((wsdl-extensions-mixin wsdl-extensions-mixin) extension-type) + (find-item-of-class extension-type (get-extensions wsdl-extensions-mixin))) + +;; Describing WSDL + +(defun describe-wsdl-soap (wsdl-document-definitions) + "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)) + (loop :for service :in (get-services wsdl-document-definitions) :do + (format t " 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))) + (let* ((binding-name (get-binding port)) + (binding (get-binding-named wsdl-document-definitions binding-name)) + (port-type-name (get-type binding)) + (port-type (get-port-type-named wsdl-document-definitions port-type-name))) + (format t " Binding: ~a~%" binding-name) + (loop :for operation :in (get-operations binding) :do + (format t " 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)) + (input-message (get-message-named wsdl-document-definitions + (get-message input-element))) + (output-message (get-message-named wsdl-document-definitions + (get-message output-element)))) + (format t " 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)) + (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)))))))) + (values)) + ;; Using WSDL to make structured SOAP calls +;; 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) +;; port-name: string of port of service to use (if nil, use first port found) +;; input: plist ("name1" value1 "name2" value2 ...) of actual parameters to use +;; output: what to do with the result (if nil: use the contents of the first part of the output message, if possible) + (defun wsdl-soap-call (wsdl operation-name &key @@ -306,13 +390,73 @@ input output) "Use WSDL to make a SOAP call of operation/port/service using input/output" - (declare (ignore wsdl operation-name service-name port-name input output)) - ;; 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) - ;; port-name: string of port of service to use (if nil, use first port found) - ;; input: plist ("name1" value1 "name2" value2) of actual parameters to use - ;; output: what to do with the result (if nil: use the contents of the first part of the output message, if possible) - t) + (declare (ignore output)) + (let* ((wsdl-document-definitions (etypecase wsdl + (wsdl-document-definitions wsdl) + (string (parse-wsdl-url wsdl)) + (pathname (parse-wsdl-file wsdl)))) + (service (if service-name + (get-service-named wsdl-document-definitions service-name) + (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)))) + (if value + (push `((,(intern (get-name part) :keyword) + xsi::|type| ,(get-type part)) + ,(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)))) + ;; add type conversions ;-) + (push (rest part-element) 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")))) ;;;; eof From scaekenberghe at common-lisp.net Wed Sep 14 07:30:04 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Wed, 14 Sep 2005 09:30:04 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/http-client.lisp Message-ID: <20050914073004.8F45D880DB@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv26398/src Modified Files: http-client.lisp Log Message: renamed close to close-all-connections to prevent conflict function<>generic-function added open-socket-stream implementations for multiple CL implementations (from s-xml-rpc/sysdeps.lisp) Date: Wed Sep 14 09:30:03 2005 Author: scaekenberghe Index: cl-soap/src/http-client.lisp diff -u cl-soap/src/http-client.lisp:1.3 cl-soap/src/http-client.lisp:1.4 --- cl-soap/src/http-client.lisp:1.3 Fri Sep 9 13:21:16 2005 +++ cl-soap/src/http-client.lisp Wed Sep 14 09:30:02 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: http-client.lisp,v 1.3 2005/09/09 11:21:16 scaekenberghe Exp $ +;;;; $Id: http-client.lisp,v 1.4 2005/09/14 07:30:02 scaekenberghe Exp $ ;;;; ;;;; A basic HTTP client, somewhat API compatible with portableaserve's do-http-request ;;;; Copied from another project (basic authorization support removed) @@ -108,7 +108,7 @@ data)) server-state))) -(defmethod close ((http-client-state http-client-state) &key abort) +(defmethod close-all-connections ((http-client-state http-client-state) &key abort) (with-slots (data) http-client-state (dolist (http-server-state data) @@ -118,7 +118,16 @@ (defun open-socket-stream (host port) #+lispworks (comm:open-tcp-stream host port) - #+openmcl (ccl:make-socket :remote-host host :remote-port port)) + #+openmcl (ccl:make-socket :remote-host host :remote-port port) + #+clisp (socket:socket-connect port host) + #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port) :input t :output t :buffering :none) + #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) + (sb-bsd-sockets:socket-connect socket + (car + (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name host))) + port) + (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t :buffering :none))) (defun get-open-connection (host port state &key force-new) (if state From scaekenberghe at common-lisp.net Thu Sep 15 11:35:56 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Thu, 15 Sep 2005 13:35:56 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: public_html/index.html Message-ID: <20050915113556.9F123880DB@common-lisp.net> Update of /project/cl-soap/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv15756 Modified Files: index.html Log Message: updated with installation instructions, status and some example code Date: Thu Sep 15 13:35:55 2005 Author: scaekenberghe Index: public_html/index.html diff -u public_html/index.html:1.3 public_html/index.html:1.4 --- public_html/index.html:1.3 Fri Sep 9 21:30:14 2005 +++ public_html/index.html Thu Sep 15 13:35:55 2005 @@ -52,6 +52,61 @@
- Good debugging support as well as initial unit and functional tests will be added.
+
Installation Instructions
+
+
- Get the source code for CL-SOAP through CVS as described above.
- Get the source code for S-XML + through CVS (do not use a released version).
- Get a recent version of the PURI package.
- Make sure ASDF works for you, add the *.asd files of the packages you just downloaded +(see the asdf manual).
- With all of the above done: +
```
(asd:oos 'asdf:load-op :cl-soap)
```
  + should load all code into your lisp image (and compile it if necessary). +
- Check out the example/test code in the test directory.
- May the source be with you, always.
+
+
Status
+
+
- S-XML was extended to support XML Namespaces
- Basic, manual SOAP calls are now possible, for example: +
```
(defun xmethods-get-quote (symbol)
+  "Calling http://services.xmethods.net/soap/urn:xmethods-delayed-quotes.wsdl"
+  (let ((ns "urn:xmethods-delayed-quotes"))
+    (s-xml:register-namespace ns "ns1" :ns1)
+    (let* ((xmethods (make-soap-end-point "http://64.124.140.30:9090/soap"))
+           (result (soap-call xmethods 
+                              '() 
+                              `((ns1::|getQuote| 
+                                 soapenv:|encodingStyle| ,+soap-enc-ns-uri+
+                                 :|xmlns:ns1| ,ns) 
+                                ((:|symbol| xsi::|type| "xsd:string") 
+                                 ,symbol)) 
+                              :soap-action "urn:xmethods-delayed-quotes#getQuote")))
+      (if (eql (lxml-get-tag result) 'ns1::|getQuoteResponse|)
+          (let ((contents (lxml-find-tag :|Result| (rest result))))
+            (if contents
+                (coerce (read-from-string (second contents)) 'float)
+              (error "Expected a  element")))
+        (error "Expected a  element")))))
```
  + Check out the test/test-basic.lisp file for more examples. +
- WSDL with SOAP bindings in url/file/stream form can now be parsed into a Common Lisp representation. Use parse-wsdl, parse-wsdl-file and parse-wsdl-url.
- The WSDL SOAP CL representation can be inspected and printed using describe-wsdl-soap.
- There is a partial implementation for making SOAP calls with structured WSDL support, for example: +
```
(defun xmethods-get-rate (country1 country2)
+  (wsdl-soap-call "http://www.xmethods.net/sd/2001/CurrencyExchangeService.wsdl"
+                  "getRate"
+                  :input `("country1" ,country1 "country2" ,country2)))
```
  +
- Some partial support for XML Schema Defintion types definition in WSDL is being implemented.
- Lot's of work remains to be done! All help is welcome.
+

Next Phase(s) (Future)
- WSDL with SOAP bindings in url/file/stream form can now be parsed into a Common Lisp representation. Use parse-wsdl, parse-wsdl-file and parse-wsdl-url.
- The WSDL SOAP CL representation can be inspected and printed using describe-wsdl-soap.
- The WSDL SOAP CL representation can be inspected and printed using describe-wsdl-soap. For example: +
```
CL-SOAP> (describe-wsdl-soap (parse-wsdl-url "http://www.xmethods.net/sd/2001/CurrencyExchangeService.wsdl"))
+WSDL Document Definitions named CurrencyExchangeService
+  Service: CurrencyExchangeService
+    Port: CurrencyExchangePort
+    SOAP Address Location "http://services.xmethods.net:80/soap"
+    Binding: tns:CurrencyExchangeBinding
+      Operation: getRate
+        Input: getRateRequest
+          Part: country2 (type xsd:string)
+          Part: country1 (type xsd:string)
+        Output: getRateResponse
+          Part: Result (type xsd:float)
```
  +
- There is a partial implementation for making SOAP calls with structured WSDL support, for example:
```
(defun xmethods-get-rate (country1 country2)
   (wsdl-soap-call "http://www.xmethods.net/sd/2001/CurrencyExchangeService.wsdl"
@@ -144,6 +157,6 @@
 Initial developers and contributors will include Sven Van Caekenberghe (Beta Nine),
 Alain Picard (Memetrics), Ivan Melotte (Beta Nine) and Nicky Peeters (Beta Nine).
 
-
$Id: index.html,v 1.4 2005/09/15 11:35:55 scaekenberghe Exp $
+$Id: index.html,v 1.5 2005/09/15 11:42:49 scaekenberghe Exp $
 
 



From scaekenberghe at common-lisp.net  Thu Sep 15 13:30:45 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 15 Sep 2005 15:30:45 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/http-client.lisp 
Message-ID: <20050915133045.9622C880DB@common-lisp.net>

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

Modified Files:
	http-client.lisp 
Log Message:
added https support for lispworks

Date: Thu Sep 15 15:30:44 2005
Author: scaekenberghe

Index: cl-soap/src/http-client.lisp
diff -u cl-soap/src/http-client.lisp:1.4 cl-soap/src/http-client.lisp:1.5
--- cl-soap/src/http-client.lisp:1.4	Wed Sep 14 09:30:02 2005
+++ cl-soap/src/http-client.lisp	Thu Sep 15 15:30:44 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: http-client.lisp,v 1.4 2005/09/14 07:30:02 scaekenberghe Exp $
+;;;; $Id: http-client.lisp,v 1.5 2005/09/15 13:30:44 scaekenberghe Exp $
 ;;;;
 ;;;; A basic HTTP client, somewhat API compatible with portableaserve's do-http-request
 ;;;; Copied from another project (basic authorization support removed)
@@ -21,10 +21,14 @@
 (defclass http-client-state () 
   ((data :initform nil)))
 
-(defvar *default-http-client-state* (make-instance 'http-client-state))
+(defun make-http-client-state ()
+  "Make a new HTTP client state object to hold open (keepalive) connections"
+  (make-instance 'http-client-state))
+
+(defvar *default-http-client-state* (make-http-client-state))
 
 (defclass http-server-state ()
-  ((host-port :accessor get-host-port :initarg :host-port)
+  ((scheme-host-port :accessor get-scheme-host-port :initarg :scheme-host-port)
    (socket :accessor get-socket :initarg :socket :initform nil)))
 
 ;; low level output
@@ -99,16 +103,17 @@
 
 ;; connection / server state management
 
-(defmethod get-http-server-state ((http-client-state http-client-state) host-port)
+(defmethod get-http-server-state ((http-client-state http-client-state) scheme-host-port)
   (with-slots (data) 
       http-client-state
-    (let ((server-state (find host-port data :key #'get-host-port :test #'string-equal)))
+    (let ((server-state (find scheme-host-port data :key #'get-scheme-host-port :test #'string-equal)))
       (unless server-state
-        (push (setf server-state (make-instance 'http-server-state :host-port host-port))
+        (push (setf server-state (make-instance 'http-server-state :scheme-host-port scheme-host-port))
               data))
       server-state)))
                 
 (defmethod close-all-connections ((http-client-state http-client-state) &key abort)
+  "Close all open connections in http-client-state (optionaly aborting them)"
   (with-slots (data) 
       http-client-state
     (dolist (http-server-state data)
@@ -116,30 +121,36 @@
         (when connection
           (ignore-errors (close connection :abort abort)))))))
 
-(defun open-socket-stream (host port)
-  #+lispworks (comm:open-tcp-stream host port)
-  #+openmcl (ccl:make-socket :remote-host host :remote-port port)
-  #+clisp (socket:socket-connect port host)
-  #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port) :input t :output t :buffering :none)
-  #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)))
-	   (sb-bsd-sockets:socket-connect socket 
-                                          (car 
-                                           (sb-bsd-sockets:host-ent-addresses 
-                                            (sb-bsd-sockets:get-host-by-name host))) 
-                                          port)
-	   (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t :buffering :none)))
+(defun open-socket-stream (scheme host port)
+  #+lispworks (ecase scheme
+                (:http (comm:open-tcp-stream host port))
+                (:https (comm:open-tcp-stream host port :ssl-ctx t)))
+  #+openmcl (when (eql scheme :http)
+              (ccl:make-socket :remote-host host :remote-port port))
+  #+clisp (when (eql scheme :http)
+            (socket:socket-connect port host))
+  #+cmu (when (eql scheme :http)
+          (sys:make-fd-stream (ext:connect-to-inet-socket host port) :input t :output t :buffering :none))
+  #+sbcl (when (eql scheme :http)
+           (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)))
+             (sb-bsd-sockets:socket-connect socket 
+                                            (car 
+                                             (sb-bsd-sockets:host-ent-addresses 
+                                              (sb-bsd-sockets:get-host-by-name host))) 
+                                            port)
+             (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t :buffering :none))))
 
-(defun get-open-connection (host port state &key force-new)
+(defun get-open-connection (scheme host port state &key force-new)
   (if state
-      (let* ((host-port (format nil "~a:~d" host port))
-             (server-state (get-http-server-state state host-port))
+      (let* ((scheme-host-port (format nil "~a://~a:~d" scheme host port))
+             (server-state (get-http-server-state state scheme-host-port))
              (connection (get-socket server-state)))
         (if (and connection (open-stream-p connection) (not force-new))
             (values connection :keep-alive)
           (progn 
             (when connection (ignore-errors (close connection)))
-            (values (setf (get-socket server-state) (open-socket-stream host port)) :new))))
-    (values (open-socket-stream host port) :new)))
+            (values (setf (get-socket server-state) (open-socket-stream scheme host port)) :new))))
+    (values (open-socket-stream scheme host port) :new)))
 
 ;; high level HTTP protocol
 
@@ -167,7 +178,9 @@
                       content content-type 
                       headers)
   "Write an HTTP request, full header and body, to stream"
-  (format-http-request-line stream "~a ~a~@[?~a~] HTTP/1.1" method (puri:uri-path uri) (puri:uri-query uri))
+  (format-http-request-line stream 
+                            "~a ~a~@[?~a~] HTTP/1.1" 
+                            method (if (puri:uri-path uri) (puri:uri-path uri) "/") (puri:uri-query uri))
   (format-http-request-line stream "Host: ~a:~d" (puri:uri-host uri) (puri:uri-port uri))
   (format-http-request-line stream "User-Agent: ~a" *http-client-agent*)
   (format-http-request-line stream "Accept: ~a" *http-client-accept*)
@@ -206,11 +219,15 @@
   (declare (ignore proxy))
   (assert (member method '(:get :put :post :delete :head)))
   (setf uri (puri:parse-uri uri))
-  (let* ((host (puri:uri-host uri))
-         (port (or (puri:uri-port uri) (setf (puri:uri-port uri) 80))))
+  (let* ((scheme (puri:uri-scheme uri))
+         (host (puri:uri-host uri))
+         (port (or (puri:uri-port uri) 
+                   (setf (puri:uri-port uri) (ecase scheme
+                                               (:http  80)
+                                               (:https 443))))))
     (multiple-value-bind (connection keep-alive)
         ;; state could hold an open (kept alive) connection to host:port
-        (get-open-connection host port state)
+        (get-open-connection scheme host port state)
       (flet ((execute-request-response ()
                (values-list `(,@(multiple-value-list 
                                  (do-one-request-response connection uri method 
@@ -225,7 +242,7 @@
             ((or stream-error #+lispworks comm:socket-error) ()
              (when keep-alive
                (setf keep-alive :new
-                     connection (get-open-connection host port state :force-new t))
+                     connection (get-open-connection scheme host port state :force-new t))
                (execute-request-response))))
         (unless state (close connection)))))))
 



From scaekenberghe at common-lisp.net  Thu Sep 15 13:31:12 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 15 Sep 2005 15:31:12 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/package.lisp 
Message-ID: <20050915133112.82553880DB@common-lisp.net>

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

Modified Files:
	package.lisp 
Log Message:
added exports to define the public API

Date: Thu Sep 15 15:31:11 2005
Author: scaekenberghe

Index: cl-soap/src/package.lisp
diff -u cl-soap/src/package.lisp:1.1 cl-soap/src/package.lisp:1.2
--- cl-soap/src/package.lisp:1.1	Mon Sep  5 10:35:55 2005
+++ cl-soap/src/package.lisp	Thu Sep 15 15:31:11 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: package.lisp,v 1.1 2005/09/05 08:35:55 scaekenberghe Exp $
+;;;; $Id: package.lisp,v 1.2 2005/09/15 13:31:11 scaekenberghe Exp $
 ;;;;
 ;;;; Definition of the CL-SOAP package
 ;;;;
@@ -15,7 +15,21 @@
 
 (defpackage :cl-soap
   (:use :common-lisp)
-  (:export)
+  (:export 
+   ;; standard soap
+   #:make-soap-end-point #:soap-call 
+   standard-soap-fault #:fault-code #:fault-string #:fault-actor #:fault-detail
+   #:*debug-stream* *last-soap-call-xml* *last-soap-result-xml*
+   +soap-enc-ns-uri+
+   ;; wsdl
+   #:parse-wsdl #:parse-wsdl-file #:parse-wsdl-url #:describe-wsdl-soap
+   #:wsdl-soal-call
+   ;; xsd
+   #:parse-xsd #:parse-xsd-file #:parse-xsd-url
+   ;; lxml
+   #:lxml-get-tag #:lxml-get-attributes #:lxml-find-tag
+   ;; html-client
+   #:do-http-request #:make-http-client-state #:close-all-connections)
   (:documentation "The Common Lisp SOAP package"))
 
 ;;;; eof



From scaekenberghe at common-lisp.net  Thu Sep 15 13:31:55 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 15 Sep 2005 15:31:55 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-wsdl.lisp 
Message-ID: <20050915133155.32FB1880DB@common-lisp.net>

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

Modified Files:
	test-wsdl.lisp 
Log Message:
marked which function don't work and why

Date: Thu Sep 15 15:31:54 2005
Author: scaekenberghe

Index: cl-soap/test/test-wsdl.lisp
diff -u cl-soap/test/test-wsdl.lisp:1.1 cl-soap/test/test-wsdl.lisp:1.2
--- cl-soap/test/test-wsdl.lisp:1.1	Mon Sep 12 16:28:41 2005
+++ cl-soap/test/test-wsdl.lisp	Thu Sep 15 15:31:54 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: test-wsdl.lisp,v 1.1 2005/09/12 14:28:41 scaekenberghe Exp $
+;;;; $Id: test-wsdl.lisp,v 1.2 2005/09/15 13:31:54 scaekenberghe Exp $
 ;;;;
 ;;;; Some test for the WSDL structured SOAP protocol
 ;;;;
@@ -17,6 +17,7 @@
 ;; http://xmethods.net
 
 (defun xmethods-get-quote (symbol)
+  ;; doesn't work: response element incorrectly described in wsdl wrt wire usage ??
   (wsdl-soap-call "http://services.xmethods.net/soap/urn:xmethods-delayed-quotes.wsdl"
                   "getQuote"
                   :input `("symbol" ,symbol)))
@@ -37,6 +38,7 @@
 ;; http://www.random.org/clients/soap/
 
 (defun get-random-number (&key unsigned)
+  ;; doesn't work: response element incorrectly described in wsdl wrt wire usage ??
   "Returns a true random  number in the interval [2^31, 2^31) or [0, 2^31)"
   (wsdl-soap-call "http://www.random.org/RandomDotOrg.wsdl"
                   (if unsigned "lrand48" "mrand48")))
@@ -44,6 +46,8 @@
 ;; accessing local AXIS services
       
 (defun axis-example3-echo (string)
+  ;; doesn't work: different input/output namespaces currently not supported
+  ;; furthermore namespaces seem to be described inconsistently in wsdl wrt wire usage ??
   (wsdl-soap-call "http://localhost:8080/axis/services/MyService?wsdl"
                   "serviceMethod"
                   :input `("arg" ,string)))



From scaekenberghe at common-lisp.net  Thu Sep 15 13:32:33 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 15 Sep 2005 15:32:33 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp 
Message-ID: <20050915133233.1B775880DB@common-lisp.net>

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

Modified Files:
	lxml.lisp 
Log Message:
added comments

Date: Thu Sep 15 15:32:32 2005
Author: scaekenberghe

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



From scaekenberghe at common-lisp.net  Thu Sep 15 13:34:46 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 15 Sep 2005 15:34:46 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp 
Message-ID: <20050915133446.45852880DB@common-lisp.net>

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

Added Files:
	test-google-adwords.lisp 
Log Message:
newly created; google adwords specific tests
testing parsing of all wsdl file

Date: Thu Sep 15 15:34:45 2005
Author: scaekenberghe




From scaekenberghe at common-lisp.net  Thu Sep 15 13:37:37 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 15 Sep 2005 15:37:37 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/cl-soap.asd 
Message-ID: <20050915133737.39EE8880DB@common-lisp.net>

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

Modified Files:
	cl-soap.asd 
Log Message:
added first step towards partial XML Schema Definition implmentation to support WSDL types schema

Date: Thu Sep 15 15:37:34 2005
Author: scaekenberghe

Index: cl-soap/cl-soap.asd
diff -u cl-soap/cl-soap.asd:1.1 cl-soap/cl-soap.asd:1.2
--- cl-soap/cl-soap.asd:1.1	Mon Sep  5 10:35:53 2005
+++ cl-soap/cl-soap.asd	Thu Sep 15 15:37:33 2005
@@ -1,6 +1,6 @@
 ;;;; -*- Mode: LISP -*-
 ;;;;
-;;;; $Id: cl-soap.asd,v 1.1 2005/09/05 08:35:53 scaekenberghe Exp $
+;;;; $Id: cl-soap.asd,v 1.2 2005/09/15 13:37:33 scaekenberghe Exp $
 ;;;;
 ;;;; The CL-SOAP ASDF system definition
 ;;;;
@@ -28,7 +28,8 @@
                  (:file "http-client" :depends-on ("package"))
                  (:file "lxml" :depends-on ("package"))
                  (:file "namespaces" :depends-on ("package"))
-                 (:file "soap" :depends-on ("package" "http-client" "namespaces" "lxml"))
+                 (:file "xsd" :depends-on ("package" "namespaces" "lxml"))
+                 (:file "soap" :depends-on ("package" "xsd" "http-client" "namespaces" "lxml"))
                  (:file "wsdl" :depends-on ("package")))))
   :depends-on (:s-xml :puri))
 



From scaekenberghe at common-lisp.net  Thu Sep 15 13:37:37 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 15 Sep 2005 15:37:37 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp
	cl-soap/src/namespaces.lisp cl-soap/src/wsdl.lisp 
Message-ID: <20050915133737.E885B880E6@common-lisp.net>

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

Modified Files:
	namespaces.lisp wsdl.lisp 
Added Files:
	xsd.lisp 
Log Message:
added first step towards partial XML Schema Definition implmentation to support WSDL types schema

Date: Thu Sep 15 15:37:35 2005
Author: scaekenberghe



Index: cl-soap/src/namespaces.lisp
diff -u cl-soap/src/namespaces.lisp:1.5 cl-soap/src/namespaces.lisp:1.6
--- cl-soap/src/namespaces.lisp:1.5	Mon Sep 12 13:24:01 2005
+++ cl-soap/src/namespaces.lisp	Thu Sep 15 15:37:34 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: namespaces.lisp,v 1.5 2005/09/12 11:24:01 scaekenberghe Exp $
+;;;; $Id: namespaces.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $
 ;;;;
 ;;;; Definition of some standard XML namespaces commonly needed for SOAP
 ;;;;
@@ -32,7 +32,9 @@
 
 (defpackage :xsd
   (:nicknames "xsd")
-  (:export)
+  (:export "schema" "element" "simpleType" "complexType" 
+           "sequence" "choice" "all" "attribute"
+           "restriction" "maxLength" "pattern" "list" "union" "enumeration")
   (:documentation "Package for symbols in the XML Schema Definition XML Namespace"))
 
 (defparameter *xsd-ns* (s-xml:register-namespace +xsd-ns-uri+ "xsd" :xsd))


Index: cl-soap/src/wsdl.lisp
diff -u cl-soap/src/wsdl.lisp:1.5 cl-soap/src/wsdl.lisp:1.6
--- cl-soap/src/wsdl.lisp:1.5	Tue Sep 13 21:23:48 2005
+++ cl-soap/src/wsdl.lisp	Thu Sep 15 15:37:34 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: wsdl.lisp,v 1.5 2005/09/13 19:23:48 scaekenberghe Exp $
+;;;; $Id: wsdl.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $
 ;;;;
 ;;;; The basic WSDL protocol: we parse the generic and soap specific parts
 ;;;;
@@ -79,10 +79,6 @@
 (defclass wsdl-message (abstract-wsdl-definition)
   ((parts :accessor get-parts :initarg :parts :initform nil)))
 
-(defclass wsdl-type (abstract-wsdl-definition)
-  ;; to be finished !!!
-  ((data-type-definitions)))
-
 ;;; WSDL SOAP Model Extension Elements
 
 (defclass wsdl-soap-address ()
@@ -122,6 +118,13 @@
 
 ;; one day we should handle  statements ;-)
 
+(defun lxml->types (lxml)
+  (let (types)
+    (loop :for element :in (rest lxml) :do
+          (if (eql (lxml-get-tag element) 'xsd:|schema|)
+              (push (lxml->schema-definition element) types)))
+    types))
+
 (defun lxml->operation-element (lxml)
   (let* ((attributes (lxml-get-attributes lxml))
          (message (getf attributes :|message|))
@@ -247,7 +250,8 @@
                                             (rest element)))
                 (wsdl-soap:|address| (setf (get-extension wsdl-port)
                                            (make-instance 'wsdl-soap-address
-                                                          :location (getf (lxml-get-attributes element) :|location|))))))
+                                                          :location (getf (lxml-get-attributes element) 
+                                                                          :|location|))))))
     wsdl-port))
 
 (defun lxml->service (lxml)
@@ -275,7 +279,8 @@
                 :do (case (lxml-get-tag element)
                       (wsdl:|documentation| (setf (get-documentation wsdl-document-definitions)
                                                   (rest element)))
-                      (wsdl:|types|)
+                      (wsdl:|types| (setf (get-types wsdl-document-definitions)
+                                          (lxml->types element)))
                       (wsdl:|message| (push (lxml->message element) 
                                             (get-messages wsdl-document-definitions)))
                       (wsdl:|portType| (push (lxml->port-type element)



From scaekenberghe at common-lisp.net  Fri Sep 16 07:51:16 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Fri, 16 Sep 2005 09:51:16 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp
	cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp 
Message-ID: <20050916075116.B9833880E6@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Fri Sep 16 12:54:36 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Fri, 16 Sep 2005 14:54:36 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp 
Message-ID: <20050916125436.B89EB88537@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Fri Sep 16 12:54:37 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Fri, 16 Sep 2005 14:54:37 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp 
Message-ID: <20050916125437.CAD158854A@common-lisp.net>

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  element")))
+      (error "Expected a  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



From scaekenberghe at common-lisp.net  Mon Sep 19 16:27:07 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 19 Sep 2005 18:27:07 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp 
Message-ID: <20050919162707.C46968855B@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Mon Sep 19 16:56:14 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 19 Sep 2005 18:56:14 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/soap.lisp 
Message-ID: <20050919165614.BBD848855B@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Mon Sep 19 16:56:16 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 19 Sep 2005 18:56:16 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp 
Message-ID: <20050919165616.D8B8C8855C@common-lisp.net>

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  element")))
       (error "Expected a  element"))))
   



From scaekenberghe at common-lisp.net  Mon Sep 19 17:54:52 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 19 Sep 2005 19:54:52 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp 
Message-ID: <20050919175452.619128855B@common-lisp.net>

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* 



From scaekenberghe at common-lisp.net  Mon Sep 19 18:26:57 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 19 Sep 2005 20:26:57 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp 
Message-ID: <20050919182657.4DA668855B@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Wed Sep 21 17:08:05 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Wed, 21 Sep 2005 19:08:05 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp
	cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp 
Message-ID: <20050921170805.C3C74880DE@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Wed Sep 21 17:08:23 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Wed, 21 Sep 2005 19:08:23 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp 
Message-ID: <20050921170823.D87F6880DE@common-lisp.net>

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  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  element")))
+      (error "Expected a  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  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)
+  "((  )*) 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)
+  "((  )*) 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



From scaekenberghe at common-lisp.net  Thu Sep 22 15:30:04 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 22 Sep 2005 17:30:04 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp 
Message-ID: <20050922153004.012A988561@common-lisp.net>

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)
   "((  )*) 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)



From scaekenberghe at common-lisp.net  Thu Sep 22 15:30:02 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 22 Sep 2005 17:30:02 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp
	cl-soap/src/xsd.lisp 
Message-ID: <20050922153002.C65AF880E6@common-lisp.net>

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~%" 
+                              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~%" 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~%" 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~%" 
+                            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~%" member-name (multiplicity-suffix member))))))
+        (indent level)
+        (format t "  ~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))



From scaekenberghe at common-lisp.net  Thu Sep 22 19:58:51 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 22 Sep 2005 21:58:51 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/cl-soap.asd 
Message-ID: <20050922195851.A37B4880E6@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Thu Sep 22 20:37:16 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 22 Sep 2005 22:37:16 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp
	cl-soap/src/xsd.lisp 
Message-ID: <20050922203716.4C197880E6@common-lisp.net>

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~%" 
+                      (format stream "    <~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~%" 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~%" 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~%" element-name element-type element-name (multiplicity-suffix element)))
+          (indent level stream)
+          (format stream "  <~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~%" 
+                    (format stream "    <~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~%" member-name (multiplicity-suffix member))))))
-        (indent level)
-        (format t "  ~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~%" member-name (multiplicity-suffix member))))))
+        (indent level stream)
+        (format stream "  ~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)



From scaekenberghe at common-lisp.net  Thu Sep 22 20:40:45 2005
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Thu, 22 Sep 2005 22:40:45 +0200 (CEST)
Subject: [cl-soap-cvs] CVS update: public_html/index.html 
Message-ID: <20050922204045.7C005880E6@common-lisp.net>

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 
 ( http://www.w3.org/TR/2001/NOTE-wsdl-20010315 )
+and the XML Schema Definition spec
+( http://www.w3.org/TR/xmlschema-1/ and
+  http://www.w3.org/TR/xmlschema-2/ )
 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).
```
- Without (dynamic) WSDL 1.1 support this would mean manual XML message (document) encoding and decoding - not very difficult but not elegant and tedious.
- Therefore there will be support for WSDL and the dynamic generation of -any necessary CL stub code (classes, methods) to access services.
- 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.
- 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) ( http://ws.apache.org/axis/ ).
- Test and (im)prove compatibility with other SOAP implementations and applications.
- Implement server side SOAP (document model).
- Define WSDL in Lisp (and autogenerate it).
- Implement the SOAP RPC model and encoding, both for client and server.
- Implement more of WSDL and XSD.
- Implement more of the SOAP RPC model and encoding, both for client and server.
Technical Notes
@@ -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).
-
$Id: index.html,v 1.5 2005/09/15 11:42:49 scaekenberghe Exp $
+
$Id: index.html,v 1.6 2005/09/22 20:40:44 scaekenberghe Exp $
From scaekenberghe at common-lisp.net Fri Sep 23 08:03:52 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 23 Sep 2005 10:03:52 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp Message-ID: <20050923080352.5452A880DE@common-lisp.net> 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
element"))) (error "Expected a
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
element"))) (error "Expected a
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 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) "(( )*) where type is Broad|Phrase|Exact" (multiple-value-bind (result headers) From scaekenberghe at common-lisp.net Fri Sep 23 08:06:46 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 23 Sep 2005 10:06:46 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/namespaces.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp Message-ID: <20050923080646.2880B880DE@common-lisp.net> 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~%" 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~%" element-name element-type element-name (multiplicity-suffix element))) + (format stream " <~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) From scaekenberghe at common-lisp.net Fri Sep 23 08:39:17 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 23 Sep 2005 10:39:17 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp Message-ID: <20050923083917.A22C2880DE@common-lisp.net> 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) From scaekenberghe at common-lisp.net Fri Sep 23 08:41:57 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 23 Sep 2005 10:41:57 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050923084157.54121880DE@common-lisp.net> 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)) From scaekenberghe at common-lisp.net Fri Sep 23 21:33:07 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 23 Sep 2005 23:33:07 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp Message-ID: <20050923213307.3C5AA880DB@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv26091/src Modified Files: wsdl.lisp xsd.lisp Log Message: added new, better structured new-bind-element & new-resolve-element functions to xsd to bind wsdl-soap-call document-style input/output binding Date: Fri Sep 23 23:33:05 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.14 cl-soap/src/wsdl.lisp:1.15 --- cl-soap/src/wsdl.lisp:1.14 Fri Sep 23 10:39:13 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.14 2005/09/23 08:39:13 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.15 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -413,10 +413,10 @@ (unless (is-optional-p part-element) (error "No input binding found for ~a:~a" (get-name input-message) (get-name part)))))) (part-element - (push (bind-element part-element - input - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (push (new-bind-element part-element + input + (get-xml-schema-definition wsdl-document-definitions) + namespace) actual-input-parameters)) (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) @@ -453,11 +453,13 @@ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) result-values))) (part-element - (push (resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) - result-values)) + (multiple-value-bind (value required) + (new-resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) + (when required + (push value result-values)))) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) ;; make the common case more handy (if (= (length result-values) 1) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.9 cl-soap/src/xsd.lisp:1.10 --- cl-soap/src/xsd.lisp:1.9 Fri Sep 23 10:41:51 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.9 2005/09/23 08:41:51 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.10 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -204,7 +204,7 @@ ;;; Binding and Resolving elements to and from actual data (defun get-name-binding (name bindings) - (second (member name bindings :test #'equal))) + (second (member (actual-name name) bindings :test #'equal))) (defun bind-element (element bindings xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) @@ -230,6 +230,99 @@ ,@(nreverse member-actual-bindings)))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) +(defun new-binding-primitive-value (name type bindings) + (let ((value (get-name-binding name bindings))) + (when value + (lisp->xsd-primitive value (intern-xsd-type-name type))))) + +(defun new-bind-primitive (element type-name bindings namespace) + (let ((value (new-binding-primitive-value (get-name element) type-name bindings))) + (if value + `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) + (if (is-optional-p element) + nil + (error "Cannot find binding for ~a" (get-name element)))))) + +(defun new-bind-type (type-name bindings super-element xml-schema-definition namespace) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type)) + (members-actual-bindings '())) + (loop :for member :in members :do + (let ((member-name (get-name member)) + (member-type (get-type member)) + (sub-bindings (or (get-name-binding (get-name type-element) bindings) + bindings))) + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type sub-bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-bindings member xml-schema-definition namespace) + (if bound + (push `(,(intern member-name (s-xml:get-package namespace)) + ,member-binding) + members-actual-bindings) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name))))))) + (values (nreverse members-actual-bindings) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (new-binding-primitive-value (get-name super-element) type bindings))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-bind-element (element bindings xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (new-bind-primitive element element-type bindings namespace)) + ((typep element-type 'xsd-complex-type) + (let ((members (get-members element-type)) + (members-actual-bindings '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for sub-binding :in bindings :do + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type + sub-binding namespace))) + (when member-binding + (incf count) + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-binding member + xml-schema-definition namespace) + (when bound + (incf count) + (push `(,(intern member-name (s-xml:get-package namespace)) + , at member-binding) + members-actual-bindings))))) + (if (zerop count) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name)))) + (let ((sub-bindings (or (get-name-binding member-type bindings) + bindings))) + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type + bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-bindings member + xml-schema-definition namespace) + (if bound + (push `(,(intern member-name (s-xml:get-package namespace)) + , at member-binding) + members-actual-bindings) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name))))))))) + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,@(nreverse members-actual-bindings)))) + (t (error "Cannot bind element ~s of type ~s" element element-type))))) + (defun resolve-element (element lxml xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) (element-type (get-element-type xml-schema-definition element))) @@ -254,10 +347,109 @@ (push (get-name element) resolved-members) (push value resolved-members))))) (values (nreverse resolved-members) t)) - (if (zerop (get-min-occurs element)) + (if (is-optional-p element) (values nil nil) (error "Expected a <~a> element" tag-name))))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) + +(defun new-lxml-primitive-value (name type lxml namespace) + (let ((tag-name (intern name (s-xml:get-package namespace)))) + (when (eql (lxml-get-tag lxml) tag-name) + (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type))))) + +(defun new-resolve-primitive (element type-name lxml namespace) + (let ((value (new-lxml-primitive-value (get-name element) type-name lxml namespace))) + (if value + (values value t) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" (get-name element)))))) + +(defun new-resolve-type (type-name lxml super-element xml-schema-definition namespace) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace))) + (member-lxml (lxml-find-tag sub-tag-name lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))) + (values (nreverse resolved-members) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-resolve-element (element lxml xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (new-resolve-primitive element element-type lxml namespace)) + ((typep element-type 'xsd-complex-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (let ((sub-lxml (lxml-get-children lxml)) + (members (get-members element-type)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in sub-lxml :do + (let ((sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members)))) + (error "Expected a <~a> element" sub-tag-name)))) + (if (zerop count) + (unless (is-optional-p member) + (error "Required element <~a> not found" member-name)))) + (let* ((sub-tag-name (intern member-name (s-xml:get-package namespace))) + (member-lxml (lxml-find-tag sub-tag-name sub-lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) + (values (list (get-name element) (nreverse resolved-members)) t)) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" tag-name))))) + (t (error "Cannot resolve element ~s of type ~s" element element-type))))) ;;; Describing XSD (with pre-rendering of XML) From scaekenberghe at common-lisp.net Fri Sep 23 21:33:07 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 23 Sep 2005 23:33:07 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp Message-ID: <20050923213307.DC4BE880DB@common-lisp.net> 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* From scaekenberghe at common-lisp.net Sun Sep 25 12:44:19 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Sun, 25 Sep 2005 14:44:19 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp cl-soap/src/xsd.lisp Message-ID: <20050925124419.CE0E78853E@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv26172/src Modified Files: lxml.lisp xsd.lisp Log Message: added 'plural' member handling to new-resolve-type added nillable element attribute to use as optional indication in sequences Date: Sun Sep 25 14:44:18 2005 Author: scaekenberghe Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.6 cl-soap/src/lxml.lisp:1.7 --- cl-soap/src/lxml.lisp:1.6 Wed Sep 21 19:08:03 2005 +++ cl-soap/src/lxml.lisp Sun Sep 25 14:44:18 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.6 2005/09/21 17:08:03 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.7 2005/09/25 12:44:18 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -38,6 +38,10 @@ (defun lxml-find-tag (tag lxml) "Find a specific tag in a lxml XML DOM list" (find tag lxml :key #'lxml-get-tag)) + +(defun lxml-find-tags (tag lxml) + "Find all elements of a specific tag in a lxml XML DOM list" + (remove-if-not #'(lambda (x) (eql (lxml-get-tag x) tag)) lxml)) ;;; internal Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.10 cl-soap/src/xsd.lisp:1.11 --- cl-soap/src/xsd.lisp:1.10 Fri Sep 23 23:33:05 2005 +++ cl-soap/src/xsd.lisp Sun Sep 25 14:44:18 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.10 2005/09/23 21:33:05 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.11 2005/09/25 12:44:18 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -26,7 +26,8 @@ ((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 1) - (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1))) + (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1) + (nillable :accessor get-nillable :initarg :nillable :initform nil))) (defmethod print-object ((object xml-schema-element) out) (print-unreadable-object (object out :type t :identity t) @@ -74,6 +75,7 @@ (type (getf attributes :|type|)) (min-occurs (getf attributes :|minOccurs|)) (max-occurs (getf attributes :|maxOccurs|)) + (nillable (getf attributes :|nillable|)) (xml-schema-element (make-instance 'xml-schema-element :name name :type type @@ -82,7 +84,8 @@ (if (equal max-occurs "unbounded") :unbounded (parse-integer max-occurs)) - 1)))) + 1) + :nillable (equal nillable "true")))) (loop :for child :in (lxml-get-children lxml) :do (push (lxml->schema-element child) (get-children xml-schema-element))) @@ -374,20 +377,40 @@ (loop :for member :in members :do (let* ((member-name (get-name member)) (member-type (get-type member)) - (sub-tag-name (intern member-name (s-xml:get-package namespace))) - (member-lxml (lxml-find-tag sub-tag-name lxml))) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type member-lxml namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members))) - (multiple-value-bind (member-value required) - (new-resolve-type member-type member-lxml member - xml-schema-definition namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members)))))) + (sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))))) + (if (zerop count) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required element <~a> not found" member-name)))) + (let ((member-lxml (lxml-find-tag sub-tag-name lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) (values (nreverse resolved-members) t)) (if (xsd-primitive-type-name-p type) (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) @@ -407,32 +430,31 @@ (resolved-members '())) (loop :for member :in members :do (let* ((member-name (get-name member)) - (member-type (get-type member))) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace)))) (if (is-plural-p member) (let ((count 0)) (loop :for item-lxml :in sub-lxml :do - (let ((sub-tag-name (intern member-name (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag item-lxml) sub-tag-name) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type item-lxml namespace) - (when required - (incf count) - (push member-name resolved-members) - (push member-value resolved-members))) + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-type member-type item-lxml member - xml-schema-definition namespace) + (new-resolve-primitive member member-type item-lxml namespace) (when required (incf count) (push member-name resolved-members) - (push member-value resolved-members)))) - (error "Expected a <~a> element" sub-tag-name)))) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members)))) + (error "Expected a <~a> element" sub-tag-name))) (if (zerop count) - (unless (is-optional-p member) + (unless (or (is-optional-p member) (get-nillable member)) (error "Required element <~a> not found" member-name)))) - (let* ((sub-tag-name (intern member-name (s-xml:get-package namespace))) - (member-lxml (lxml-find-tag sub-tag-name sub-lxml))) + (let ((member-lxml (lxml-find-tag sub-tag-name sub-lxml))) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) (new-resolve-primitive member member-type member-lxml namespace) @@ -508,10 +530,11 @@ (member-type (get-type member))) (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format stream " Member ~s of primitive type ~s [~a]~%" - member-name member-type (describe-multiplicity member)) + (format stream " Member ~s of primitive type ~s [~a]~@[ nillable~]~%" + member-name member-type (describe-multiplicity member) (get-nillable member)) (progn - (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (format stream " Member ~s [~a]~@[ nillable~]~%" member-name + (describe-multiplicity member) (get-nillable member)) (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream)))))) (if (xsd-primitive-type-name-p type) @@ -528,23 +551,25 @@ (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)) + (format stream "Element ~s of primitive type ~s [~a]~@[ nillable~]~%" + element-name element-type (describe-multiplicity element) (get-nillable element)) (indent level stream) (format stream " <~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)) + (format stream "Element ~s [~a]~@[ nillable~]~%" element-name + (describe-multiplicity element) (get-nillable element)) (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format stream " Member ~s of primitive type ~s [~a]~%" - member-name member-type (describe-multiplicity member)) + (format stream " Member ~s of primitive type ~s[ ~a]~@[ nillable~]~%" + member-name member-type (describe-multiplicity member) (get-nillable member)) (progn - (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (format stream " Member ~s [~a]~@[ nillable~]~%" member-name + (describe-multiplicity member) (get-nillable member)) (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream))))) (indent level stream) From scaekenberghe at common-lisp.net Mon Sep 26 08:43:57 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 10:43:57 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050926084357.A92558815C@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv12562/src Modified Files: xsd.lisp Log Message: fixed xsd primitive handling of false boolean Date: Mon Sep 26 10:43:57 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.11 cl-soap/src/xsd.lisp:1.12 --- cl-soap/src/xsd.lisp:1.11 Sun Sep 25 14:44:18 2005 +++ cl-soap/src/xsd.lisp Mon Sep 26 10:43:56 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.11 2005/09/25 12:44:18 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.12 2005/09/26 08:43:56 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -357,12 +357,14 @@ (defun new-lxml-primitive-value (name type lxml namespace) (let ((tag-name (intern name (s-xml:get-package namespace)))) - (when (eql (lxml-get-tag lxml) tag-name) - (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type))))) + (if (eql (lxml-get-tag lxml) tag-name) + (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type)) t) + (values nil nil)))) (defun new-resolve-primitive (element type-name lxml namespace) - (let ((value (new-lxml-primitive-value (get-name element) type-name lxml namespace))) - (if value + (multiple-value-bind (value present) + (new-lxml-primitive-value (get-name element) type-name lxml namespace) + (if present (values value t) (if (is-optional-p element) (values nil nil) @@ -413,8 +415,7 @@ (push member-value resolved-members)))))))) (values (nreverse resolved-members) t)) (if (xsd-primitive-type-name-p type) - (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) - (if value (values value t) (values nil nil))) + (new-lxml-primitive-value (get-name super-element) type lxml namespace) (error "unexpected type"))))) (defun new-resolve-element (element lxml xml-schema-definition namespace) From scaekenberghe at common-lisp.net Mon Sep 26 10:41:52 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 12:41:52 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp Message-ID: <20050926104152.51C5288549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv21363/src Modified Files: wsdl.lisp xsd.lisp Log Message: removed old resolve/bind -element and replaced them by new-* versions Date: Mon Sep 26 12:41:51 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.15 cl-soap/src/wsdl.lisp:1.16 --- cl-soap/src/wsdl.lisp:1.15 Fri Sep 23 23:33:05 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 26 12:41:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.15 2005/09/23 21:33:05 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.16 2005/09/26 10:41:50 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -413,10 +413,10 @@ (unless (is-optional-p part-element) (error "No input binding found for ~a:~a" (get-name input-message) (get-name part)))))) (part-element - (push (new-bind-element part-element - input - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (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))) @@ -454,10 +454,10 @@ result-values))) (part-element (multiple-value-bind (value required) - (new-resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) (when required (push value result-values)))) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.12 cl-soap/src/xsd.lisp:1.13 --- cl-soap/src/xsd.lisp:1.12 Mon Sep 26 10:43:56 2005 +++ cl-soap/src/xsd.lisp Mon Sep 26 12:41:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.12 2005/09/26 08:43:56 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.13 2005/09/26 10:41:50 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -209,44 +209,20 @@ (defun get-name-binding (name bindings) (second (member (actual-name name) bindings :test #'equal))) -(defun bind-element (element bindings xml-schema-definition namespace) - (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) - (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 new-binding-primitive-value (name type bindings) +(defun binding-primitive-value (name type bindings) (let ((value (get-name-binding name bindings))) (when value (lisp->xsd-primitive value (intern-xsd-type-name type))))) -(defun new-bind-primitive (element type-name bindings namespace) - (let ((value (new-binding-primitive-value (get-name element) type-name bindings))) +(defun bind-primitive (element type-name bindings namespace) + (let ((value (binding-primitive-value (get-name element) type-name bindings))) (if value `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) (if (is-optional-p element) nil (error "Cannot find binding for ~a" (get-name element)))))) -(defun new-bind-type (type-name bindings super-element xml-schema-definition namespace) +(defun bind-type (type-name bindings super-element xml-schema-definition namespace) (let* ((type-element (get-element-named xml-schema-definition type-name)) (type (get-element-type xml-schema-definition type-element))) (if (typep type 'xsd-complex-type) @@ -258,11 +234,11 @@ (sub-bindings (or (get-name-binding (get-name type-element) bindings) bindings))) (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (new-bind-primitive member member-type sub-bindings namespace))) + (let ((member-binding (bind-primitive member member-type sub-bindings namespace))) (when member-binding (push member-binding members-actual-bindings))) (multiple-value-bind (member-binding bound) - (new-bind-type member-type sub-bindings member xml-schema-definition namespace) + (bind-type member-type sub-bindings member xml-schema-definition namespace) (if bound (push `(,(intern member-name (s-xml:get-package namespace)) ,member-binding) @@ -271,15 +247,15 @@ (error "Required member ~a not bound" member-name))))))) (values (nreverse members-actual-bindings) t)) (if (xsd-primitive-type-name-p type) - (let ((value (new-binding-primitive-value (get-name super-element) type bindings))) + (let ((value (binding-primitive-value (get-name super-element) type bindings))) (if value (values value t) (values nil nil))) (error "unexpected type"))))) -(defun new-bind-element (element bindings xml-schema-definition namespace) +(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) - (new-bind-primitive element element-type bindings namespace)) + (bind-primitive element element-type bindings namespace)) ((typep element-type 'xsd-complex-type) (let ((members (get-members element-type)) (members-actual-bindings '())) @@ -290,14 +266,14 @@ (let ((count 0)) (loop :for sub-binding :in bindings :do (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (new-bind-primitive member member-type - sub-binding namespace))) + (let ((member-binding (bind-primitive member member-type + sub-binding namespace))) (when member-binding (incf count) (push member-binding members-actual-bindings))) (multiple-value-bind (member-binding bound) - (new-bind-type member-type sub-binding member - xml-schema-definition namespace) + (bind-type member-type sub-binding member + xml-schema-definition namespace) (when bound (incf count) (push `(,(intern member-name (s-xml:get-package namespace)) @@ -309,13 +285,13 @@ (let ((sub-bindings (or (get-name-binding member-type bindings) bindings))) (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (new-bind-primitive member member-type - bindings namespace))) + (let ((member-binding (bind-primitive member member-type + bindings namespace))) (when member-binding (push member-binding members-actual-bindings))) (multiple-value-bind (member-binding bound) - (new-bind-type member-type sub-bindings member - xml-schema-definition namespace) + (bind-type member-type sub-bindings member + xml-schema-definition namespace) (if bound (push `(,(intern member-name (s-xml:get-package namespace)) , at member-binding) @@ -326,51 +302,22 @@ ,@(nreverse members-actual-bindings)))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) -(defun resolve-element (element lxml xml-schema-definition namespace) - (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) - (element-type (get-element-type xml-schema-definition element))) - (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 (is-optional-p element) - (values nil nil) - (error "Expected a <~a> element" tag-name))))) - (t (error "Cannot bind element ~s of type ~s" element element-type))))) - -(defun new-lxml-primitive-value (name type lxml namespace) +(defun lxml-primitive-value (name type lxml namespace) (let ((tag-name (intern name (s-xml:get-package namespace)))) (if (eql (lxml-get-tag lxml) tag-name) (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type)) t) (values nil nil)))) -(defun new-resolve-primitive (element type-name lxml namespace) +(defun resolve-primitive (element type-name lxml namespace) (multiple-value-bind (value present) - (new-lxml-primitive-value (get-name element) type-name lxml namespace) + (lxml-primitive-value (get-name element) type-name lxml namespace) (if present (values value t) (if (is-optional-p element) (values nil nil) (error "Expected a <~a> element" (get-name element)))))) -(defun new-resolve-type (type-name lxml super-element xml-schema-definition namespace) +(defun resolve-type (type-name lxml super-element xml-schema-definition namespace) (let* ((type-element (get-element-named xml-schema-definition type-name)) (type (get-element-type xml-schema-definition type-element))) (if (typep type 'xsd-complex-type) @@ -385,14 +332,14 @@ (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type item-lxml namespace) + (resolve-primitive member member-type item-lxml namespace) (when required (incf count) (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type item-lxml member - xml-schema-definition namespace) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) (when required (incf count) (push member-name resolved-members) @@ -403,26 +350,26 @@ (let ((member-lxml (lxml-find-tag sub-tag-name lxml))) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type member-lxml namespace) + (resolve-primitive member member-type member-lxml namespace) (when required (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type member-lxml member - xml-schema-definition namespace) + (resolve-type member-type member-lxml member + xml-schema-definition namespace) (when required (push member-name resolved-members) (push member-value resolved-members)))))))) (values (nreverse resolved-members) t)) (if (xsd-primitive-type-name-p type) - (new-lxml-primitive-value (get-name super-element) type lxml namespace) + (lxml-primitive-value (get-name super-element) type lxml namespace) (error "unexpected type"))))) -(defun new-resolve-element (element lxml xml-schema-definition namespace) +(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) - (new-resolve-primitive element element-type lxml namespace)) + (resolve-primitive element element-type lxml namespace)) ((typep element-type 'xsd-complex-type) (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) (if (eql (lxml-get-tag lxml) tag-name) @@ -439,14 +386,14 @@ (if (eql (lxml-get-tag item-lxml) sub-tag-name) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type item-lxml namespace) + (resolve-primitive member member-type item-lxml namespace) (when required (incf count) (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type item-lxml member - xml-schema-definition namespace) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) (when required (incf count) (push member-name resolved-members) @@ -458,13 +405,13 @@ (let ((member-lxml (lxml-find-tag sub-tag-name sub-lxml))) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type member-lxml namespace) + (resolve-primitive member member-type member-lxml namespace) (when required (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type member-lxml member - xml-schema-definition namespace) + (resolve-type member-type member-lxml member + xml-schema-definition namespace) (when required (push member-name resolved-members) (push member-value resolved-members)))))))) From scaekenberghe at common-lisp.net Mon Sep 26 10:52:45 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 12:52:45 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp Message-ID: <20050926105245.C8DE388549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv22402/src Modified Files: wsdl.lisp Log Message: renamed bind-header to bind-input-headers now using bind-element in bind-input-headers Date: Mon Sep 26 12:52:45 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.16 cl-soap/src/wsdl.lisp:1.17 --- cl-soap/src/wsdl.lisp:1.16 Mon Sep 26 12:41:50 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 26 12:52:45 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.16 2005/09/26 10:41:50 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.17 2005/09/26 10:52:45 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -421,25 +421,18 @@ (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) -(defun bind-headers (soap-input-headers headers wsdl-document-definitions) - ;; default namespace! +(defun bind-input-headers (soap-input-headers headers wsdl-document-definitions) (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 (get-xml-schema-definition 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))))) + (let* ((element (get-element part)) + (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) + (xml-schema-definition (get-xml-schema-definition wsdl-document-definitions)) + (binding (bind-element element headers xml-schema-definition namespace))) + (when binding + (push binding actual-headers)))) (nreverse actual-headers))) (defun bind-output-parts (result output-message output wsdl-document-definitions) - ;; namespaces! (declare (ignore output)) (let ((namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) (result-values '())) @@ -488,7 +481,7 @@ (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) + (bind-input-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 @@ -532,14 +525,12 @@ (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))) + (let ((soap-input-headers (get-extensions-of-class binding-operation-input 'wsdl-soap-header))) + (loop :for soap-input-header :in soap-input-headers + :collect (let* ((part-name (get-part soap-input-header)) + (message-name (get-message soap-input-header)) + (header-message (get-message-named wsdl-document-definitions message-name))) + (get-part-named header-message part-name))))) (defun wsdl-soap-call-internal (wsdl-document-definitions port From scaekenberghe at common-lisp.net Mon Sep 26 11:08:43 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 13:08:43 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/http-client.lisp Message-ID: <20050926110843.1610188549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23437/src Modified Files: http-client.lisp Log Message: some code reformatting Date: Mon Sep 26 13:08:42 2005 Author: scaekenberghe Index: cl-soap/src/http-client.lisp diff -u cl-soap/src/http-client.lisp:1.5 cl-soap/src/http-client.lisp:1.6 --- cl-soap/src/http-client.lisp:1.5 Thu Sep 15 15:30:44 2005 +++ cl-soap/src/http-client.lisp Mon Sep 26 13:08:42 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: http-client.lisp,v 1.5 2005/09/15 13:30:44 scaekenberghe Exp $ +;;;; $Id: http-client.lisp,v 1.6 2005/09/26 11:08:42 scaekenberghe Exp $ ;;;; ;;;; A basic HTTP client, somewhat API compatible with portableaserve's do-http-request ;;;; Copied from another project (basic authorization support removed) @@ -58,7 +58,8 @@ (defun response-read-headers (stream) (loop :for line = (read-line stream nil) - :until (or (zerop (length line)) + :until (or (null line) + (zerop (length line)) (char= (elt line 0) #\return) (char= (elt line 0) #\linefeed)) :collect (let ((colon (position #\: line))) @@ -80,7 +81,8 @@ (return) (let ((total-chunk-size 0)) (loop (let ((size (read-sequence buffer stream - :end (min (length buffer) (- chunk-size total-chunk-size))))) + :end (min (length buffer) + (- chunk-size total-chunk-size))))) (incf total-chunk-size size) (write-sequence buffer out :end size) (when (= total-chunk-size chunk-size) @@ -93,8 +95,10 @@ (total-size 0)) (with-output-to-string (out) (loop - (let ((size (read-sequence buffer stream :end (when length - (min (length buffer) (- length total-size)))))) + (let ((size (read-sequence buffer stream + :end (when length + (min (length buffer) + (- length total-size)))))) (incf total-size size) (write-sequence buffer out :end size) (when (or (and length (= total-size length)) @@ -106,9 +110,11 @@ (defmethod get-http-server-state ((http-client-state http-client-state) scheme-host-port) (with-slots (data) http-client-state - (let ((server-state (find scheme-host-port data :key #'get-scheme-host-port :test #'string-equal))) + (let ((server-state (find scheme-host-port data + :key #'get-scheme-host-port :test #'string-equal))) (unless server-state - (push (setf server-state (make-instance 'http-server-state :scheme-host-port scheme-host-port)) + (push (setf server-state (make-instance 'http-server-state + :scheme-host-port scheme-host-port)) data)) server-state))) @@ -130,15 +136,19 @@ #+clisp (when (eql scheme :http) (socket:socket-connect port host)) #+cmu (when (eql scheme :http) - (sys:make-fd-stream (ext:connect-to-inet-socket host port) :input t :output t :buffering :none)) + (sys:make-fd-stream (ext:connect-to-inet-socket host port) + :input t :output t :buffering :none)) #+sbcl (when (eql scheme :http) - (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) (sb-bsd-sockets:socket-connect socket (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name host))) port) - (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t :buffering :none)))) + (sb-bsd-sockets:socket-make-stream socket + :element-type 'character + :input t :output t :buffering :none)))) (defun get-open-connection (scheme host port state &key force-new) (if state @@ -149,7 +159,8 @@ (values connection :keep-alive) (progn (when connection (ignore-errors (close connection))) - (values (setf (get-socket server-state) (open-socket-stream scheme host port)) :new)))) + (values (setf (get-socket server-state) (open-socket-stream scheme host port)) + :new)))) (values (open-socket-stream scheme host port) :new))) ;; high level HTTP protocol @@ -180,7 +191,9 @@ "Write an HTTP request, full header and body, to stream" (format-http-request-line stream "~a ~a~@[?~a~] HTTP/1.1" - method (if (puri:uri-path uri) (puri:uri-path uri) "/") (puri:uri-query uri)) + method (if (puri:uri-path uri) + (puri:uri-path uri) "/") + (puri:uri-query uri)) (format-http-request-line stream "Host: ~a:~d" (puri:uri-host uri) (puri:uri-port uri)) (format-http-request-line stream "User-Agent: ~a" *http-client-agent*) (format-http-request-line stream "Accept: ~a" *http-client-accept*) @@ -231,7 +244,8 @@ (flet ((execute-request-response () (values-list `(,@(multiple-value-list (do-one-request-response connection uri method - :content content :content-type content-type + :content content + :content-type content-type :headers headers)) ,keep-alive)))) (unwind-protect From scaekenberghe at common-lisp.net Mon Sep 26 11:14:57 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 13:14:57 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp Message-ID: <20050926111457.B280788556@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv23484/test Modified Files: test-google-adwords.lisp Log Message: incorporated wsdl caching to main code Date: Mon Sep 26 13:14:56 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.8 cl-soap/test/test-google-adwords.lisp:1.9 --- cl-soap/test/test-google-adwords.lisp:1.8 Fri Sep 23 23:33:06 2005 +++ cl-soap/test/test-google-adwords.lisp Mon Sep 26 13:14:56 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.8 2005/09/23 21:33:06 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.9 2005/09/26 11:14:56 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -58,14 +58,6 @@ (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 From scaekenberghe at common-lisp.net Mon Sep 26 11:14:56 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 13:14:56 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp Message-ID: <20050926111456.4135B88549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23484/src Modified Files: wsdl.lisp Log Message: incorporated wsdl caching to main code Date: Mon Sep 26 13:14:55 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.17 cl-soap/src/wsdl.lisp:1.18 --- cl-soap/src/wsdl.lisp:1.17 Mon Sep 26 12:52:45 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 26 13:14:55 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.17 2005/09/26 10:52:45 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.18 2005/09/26 11:14:55 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -300,6 +300,25 @@ (let ((buffer (do-http-request url))) (with-input-from-string (in buffer) (parse-wsdl in)))) + +;; A simple caching mechanism for WSDL's by URL + +(defvar *wsdl-cache* (make-hash-table :test #'equal)) + +(defun wsdl-cache-get (url) + "Access a possibly cached WSDL url, downloading and parsing it if necessary" + (let ((cached (gethash url *wsdl-cache*))) + (if cached + cached + (setf (gethash url *wsdl-cache*) (parse-wsdl-url url))))) + +(defun wsdl-cache-clear (url) + "Clear the WSDL caching of url" + (remhash url *wsdl-cache*)) + +(defun wsdl-cache-clear-all () + "Clear the whole WSDL cache" + (clrhash *wsdl-cache*)) ;; Interpreting the WSDL model From scaekenberghe at common-lisp.net Mon Sep 26 11:15:33 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 13:15:33 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/soap.lisp Message-ID: <20050926111533.7EBCA88549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23840/src Modified Files: soap.lisp Log Message: added report-soap-call debugging tool Date: Mon Sep 26 13:15:33 2005 Author: scaekenberghe Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.6 cl-soap/src/soap.lisp:1.7 --- cl-soap/src/soap.lisp:1.6 Mon Sep 19 18:56:13 2005 +++ cl-soap/src/soap.lisp Mon Sep 26 13:15:32 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.6 2005/09/19 16:56:13 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.7 2005/09/26 11:15:32 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -84,6 +84,12 @@ (defvar *last-soap-result-xml* nil "When *debug-stream* is non-nil, will contain the last SOAP result's parsed XML") + +(defun report-soap-call () + (format t "~&;; CL-SOAP last call and result envelopes:~%") + (pprint *last-soap-call-xml*) + (terpri) + (pprint *last-soap-result-xml*)) (defun soap-call (server-end-point header From scaekenberghe at common-lisp.net Mon Sep 26 11:17:43 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 13:17:43 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/package.lisp Message-ID: <20050926111743.B82F488556@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv24509/src Modified Files: package.lisp Log Message: some code cleanup, more exports Date: Mon Sep 26 13:17:43 2005 Author: scaekenberghe Index: cl-soap/src/package.lisp diff -u cl-soap/src/package.lisp:1.2 cl-soap/src/package.lisp:1.3 --- cl-soap/src/package.lisp:1.2 Thu Sep 15 15:31:11 2005 +++ cl-soap/src/package.lisp Mon Sep 26 13:17:42 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: package.lisp,v 1.2 2005/09/15 13:31:11 scaekenberghe Exp $ +;;;; $Id: package.lisp,v 1.3 2005/09/26 11:17:42 scaekenberghe Exp $ ;;;; ;;;; Definition of the CL-SOAP package ;;;; @@ -19,10 +19,11 @@ ;; standard soap #:make-soap-end-point #:soap-call standard-soap-fault #:fault-code #:fault-string #:fault-actor #:fault-detail - #:*debug-stream* *last-soap-call-xml* *last-soap-result-xml* + #:*debug-stream* *last-soap-call-xml* *last-soap-result-xml* #:report-soap-call +soap-enc-ns-uri+ ;; wsdl #:parse-wsdl #:parse-wsdl-file #:parse-wsdl-url #:describe-wsdl-soap + #:wsdl-cache-get #:wsdl-cache-clear #:wsdl-cache-clear-all #:wsdl-soal-call ;; xsd #:parse-xsd #:parse-xsd-file #:parse-xsd-url From scaekenberghe at common-lisp.net Mon Sep 26 11:17:43 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 13:17:43 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/cl-soap.asd Message-ID: <20050926111743.AFED488549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap In directory common-lisp.net:/tmp/cvs-serv24509 Modified Files: cl-soap.asd Log Message: some code cleanup, more exports Date: Mon Sep 26 13:17:42 2005 Author: scaekenberghe Index: cl-soap/cl-soap.asd diff -u cl-soap/cl-soap.asd:1.3 cl-soap/cl-soap.asd:1.4 --- cl-soap/cl-soap.asd:1.3 Thu Sep 22 21:58:50 2005 +++ cl-soap/cl-soap.asd Mon Sep 26 13:17:41 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: cl-soap.asd,v 1.3 2005/09/22 19:58:50 scaekenberghe Exp $ +;;;; $Id: cl-soap.asd,v 1.4 2005/09/26 11:17:41 scaekenberghe Exp $ ;;;; ;;;; The CL-SOAP ASDF system definition ;;;; @@ -19,7 +19,7 @@ :maintainer "Sven Van Caekenberghe " :licence "Lesser Lisp General Public License (LLGPL)" :description "Common Lisp SOAP Package" - :long-description "CL-SOAP is an implementation of the SOAP 1.1 and WSDL 1.1 procotols" + :long-description "CL-SOAP is an implementation of the SOAP 1.1, WSDL 1.1 and XML Schema Definition procotols" :components ((:module From scaekenberghe at common-lisp.net Mon Sep 26 14:40:40 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Mon, 26 Sep 2005 16:40:40 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050926144040.8927688569@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv5816/src Modified Files: xsd.lisp Log Message: we now return repeatable elements as full lists Date: Mon Sep 26 16:40:38 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.13 cl-soap/src/xsd.lisp:1.14 --- cl-soap/src/xsd.lisp:1.13 Mon Sep 26 12:41:50 2005 +++ cl-soap/src/xsd.lisp Mon Sep 26 16:40:37 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.13 2005/09/26 10:41:50 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.14 2005/09/26 14:40:37 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -335,15 +335,13 @@ (resolve-primitive member member-type item-lxml namespace) (when required (incf count) - (push member-name resolved-members) - (push member-value resolved-members))) + (push (list member-name member-value) resolved-members))) (multiple-value-bind (member-value required) (resolve-type member-type item-lxml member xml-schema-definition namespace) (when required (incf count) - (push member-name resolved-members) - (push member-value resolved-members))))) + (push (list member-name member-value) resolved-members))))) (if (zerop count) (unless (or (is-optional-p member) (get-nillable member)) (error "Required element <~a> not found" member-name)))) @@ -389,15 +387,13 @@ (resolve-primitive member member-type item-lxml namespace) (when required (incf count) - (push member-name resolved-members) - (push member-value resolved-members))) + (push (list member-name member-value) resolved-members))) (multiple-value-bind (member-value required) (resolve-type member-type item-lxml member xml-schema-definition namespace) (when required (incf count) - (push member-name resolved-members) - (push member-value resolved-members)))) + (push (list member-name member-value) resolved-members)))) (error "Expected a <~a> element" sub-tag-name))) (if (zerop count) (unless (or (is-optional-p member) (get-nillable member)) From scaekenberghe at common-lisp.net Tue Sep 27 05:39:35 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 27 Sep 2005 07:39:35 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp Message-ID: <20050927053935.B24B488549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv3520/test Modified Files: test-google-adwords.lisp Log Message: added get-all-adgroups Date: Tue Sep 27 07:39:34 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.9 cl-soap/test/test-google-adwords.lisp:1.10 --- cl-soap/test/test-google-adwords.lisp:1.9 Mon Sep 26 13:14:56 2005 +++ cl-soap/test/test-google-adwords.lisp Tue Sep 27 07:39:34 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.9 2005/09/26 11:14:56 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.10 2005/09/27 05:39:34 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -223,6 +223,16 @@ :headers `("email" ,*google-adwords-email* "password" ,*google-adwords-password* "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token* + "clientEmail" ,*google-client-email*))) + +(defun get-all-adgroups (campaign-id) + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl") + "getAllAdGroups" + :input `("campaignID" ,campaign-id) + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* "token" ,*google-adwords-token* "clientEmail" ,*google-client-email*))) From scaekenberghe at common-lisp.net Tue Sep 27 05:41:19 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 27 Sep 2005 07:41:19 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050927054119.3D4E088549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv3537/src Modified Files: xsd.lisp Log Message: bugfix: solitary primitive tags, like or empty tags like where not handles correctly as primitive; now using lxml-* accessors changed behavior of primitive string handling: NIL -> "" Date: Tue Sep 27 07:41:18 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.14 cl-soap/src/xsd.lisp:1.15 --- cl-soap/src/xsd.lisp:1.14 Mon Sep 26 16:40:37 2005 +++ cl-soap/src/xsd.lisp Tue Sep 27 07:41:18 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.14 2005/09/26 14:40:37 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.15 2005/09/27 05:41:18 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -305,7 +305,7 @@ (defun lxml-primitive-value (name type lxml namespace) (let ((tag-name (intern name (s-xml:get-package namespace)))) (if (eql (lxml-get-tag lxml) tag-name) - (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type)) t) + (values (xsd-primitive->lisp (first (lxml-get-children lxml)) (intern-xsd-type-name type)) t) (values nil nil)))) (defun resolve-primitive (element type-name lxml namespace) @@ -691,9 +691,9 @@ "Convert the XSD string value to a Common Lisp value, interpreting it as type" (ecase type ((:string :normalizedString :token) - value) + (if (null value) "" value)) ((:Name :QName :NCName :anyURI) - value) + (if (null value) "" value)) ((:integer :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger :long :unsignedLong :int :unsignedInt :short :unsignedShort From scaekenberghe at common-lisp.net Tue Sep 27 16:25:19 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 27 Sep 2005 18:25:19 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/namespaces.lisp cl-soap/src/xsd.lisp Message-ID: <20050927162519.4E19F88558@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv16612/src Modified Files: namespaces.lisp xsd.lisp Log Message: added basic support for XSD complexContent combined with an extension more test code Date: Tue Sep 27 18:25:17 2005 Author: scaekenberghe Index: cl-soap/src/namespaces.lisp diff -u cl-soap/src/namespaces.lisp:1.7 cl-soap/src/namespaces.lisp:1.8 --- cl-soap/src/namespaces.lisp:1.7 Fri Sep 23 10:06:36 2005 +++ cl-soap/src/namespaces.lisp Tue Sep 27 18:25:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: namespaces.lisp,v 1.7 2005/09/23 08:06:36 scaekenberghe Exp $ +;;;; $Id: namespaces.lisp,v 1.8 2005/09/27 16:25:17 scaekenberghe Exp $ ;;;; ;;;; Definition of some standard XML namespaces commonly needed for SOAP ;;;; @@ -32,9 +32,9 @@ (defpackage :xsd (:nicknames "xsd") - (:export "schema" "element" "simpleType" "complexType" + (:export "schema" "element" "simpleType" "complexType" "complexContent" "sequence" "choice" "all" "attribute" - "restriction" "maxLength" "pattern" "list" "union" "enumeration") + "restriction" "extension" "maxLength" "pattern" "list" "union" "enumeration") (:documentation "Package for symbols in the XML Schema Definition XML Namespace")) (defparameter *xsd-ns* (s-xml:register-namespace +xsd-ns-uri+ "xsd" :xsd)) @@ -48,7 +48,7 @@ (defpackage :xsi (:nicknames "xsi") - (:export) + (:export "null") (:documentation "Package for symbols in the XML Schema Instance XML Namespace")) (defparameter *xsi-ns* (s-xml:register-namespace +xsi-ns-uri+ "xsi" :xsi)) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.15 cl-soap/src/xsd.lisp:1.16 --- cl-soap/src/xsd.lisp:1.15 Tue Sep 27 07:41:18 2005 +++ cl-soap/src/xsd.lisp Tue Sep 27 18:25:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.15 2005/09/27 05:41:18 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.16 2005/09/27 16:25:17 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -46,6 +46,9 @@ (defclass xsd-complex-type (xsd-type) ()) +(defclass xsd-complex-content (children-mixin) + ()) + (defclass xsd-compositor (children-mixin) ()) @@ -61,6 +64,9 @@ (defclass xsd-restriction () ((base :accessor get-base :initarg :base :initform nil))) +(defclass xsd-extension (children-mixin) + ((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))) @@ -106,11 +112,25 @@ (push (lxml->schema-element child) (get-children xsd-type))) xsd-type)) + (xsd:|complexContent| + (let* ((xsd-complex-content (make-instance 'xsd-complex-content))) + (loop :for child :in (lxml-get-children lxml) :do + (push (lxml->schema-element child) + (get-children xsd-complex-content))) + xsd-complex-content)) (xsd:|restriction| (let* ((attributes (lxml-get-attributes lxml)) (base (getf attributes :|base|)) (xsd-restriction (make-instance 'xsd-restriction :base base))) xsd-restriction)) + (xsd:|extension| + (let* ((attributes (lxml-get-attributes lxml)) + (base (getf attributes :|base|)) + (xsd-extension (make-instance 'xsd-extension :base base))) + (loop :for child :in (lxml-get-children lxml) :do + (push (lxml->schema-element child) + (get-children xsd-extension))) + xsd-extension)) (xsd:|sequence| (let ((xsd-sequence (make-instance 'xsd-sequence))) (loop :for child :in (lxml-get-children lxml) :do @@ -183,11 +203,22 @@ (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 (for now)" + "Return the list of members of xsd-complex-type, provided it is a sequence or a complex-content (for now)" (let ((first-child (first (get-children xsd-complex-type)))) - (when (and first-child - (typep first-child 'xsd-sequence)) - (get-children first-child)))) + (cond ((and first-child (typep first-child 'xsd-sequence)) + (get-children first-child)) + ((and first-child (typep first-child 'xsd-complex-content)) + (get-members first-child))))) + +(defmethod get-members ((xsd-complex-content xsd-complex-content)) + "Return the list of members of xsd-complex-content, provided it is a base type sequence extension (for now)" + (let ((first-child (first (get-children xsd-complex-content)))) + (when (and first-child (typep first-child 'xsd-extension)) + (let ((base-members (get-members (get-base first-child))) + (first-child (first (get-children first-child)))) + (if (and first-child (typep first-child 'xsd-sequence)) + (append base-members (get-members first-child)) + base-members))))) (defmethod get-multiplicity ((xml-schema-element xml-schema-element)) (with-slots (min-occurs max-occurs) From scaekenberghe at common-lisp.net Tue Sep 27 16:25:21 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 27 Sep 2005 18:25:21 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-xsd.lisp cl-soap/test/test-google-adwords.lisp Message-ID: <20050927162521.10E208855E@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv16612/test Modified Files: test-google-adwords.lisp Added Files: test-xsd.lisp Log Message: added basic support for XSD complexContent combined with an extension more test code Date: Tue Sep 27 18:25:18 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.10 cl-soap/test/test-google-adwords.lisp:1.11 --- cl-soap/test/test-google-adwords.lisp:1.10 Tue Sep 27 07:39:34 2005 +++ cl-soap/test/test-google-adwords.lisp Tue Sep 27 18:25:18 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.10 2005/09/27 05:39:34 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.11 2005/09/27 16:25:18 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -166,7 +166,6 @@ (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) @@ -235,5 +234,29 @@ "useragent" ,*google-adwords-user-agent* "token" ,*google-adwords-token* "clientEmail" ,*google-client-email*))) + +(defun add-campaign (client-email daily-budget status &key name language-targeting geo-targeting) + ;; to be completed + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl") + "addCampaign" + ;; input placeholder !! + :input `(,daily-budget ,status name ,name ,language-targeting ,geo-targeting) + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token* + "clientEmail" ,client-email))) + +(defun schedule-report-job (client-email report-job) + ;; to be completed + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/ReportService?") + "scheduleReportJob" + ;; input placeholder !! + :input `(,report-job) + :headers `("email" ,*google-adwords-email* + "password" ,*google-adwords-password* + "useragent" ,*google-adwords-user-agent* + "token" ,*google-adwords-token* + "clientEmail" ,client-email))) ;;;; eof From scaekenberghe at common-lisp.net Tue Sep 27 18:22:55 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 27 Sep 2005 20:22:55 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050927182255.0F8C888558@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv24844/src Modified Files: xsd.lisp Log Message: some refactoring Date: Tue Sep 27 20:22:54 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.16 cl-soap/src/xsd.lisp:1.17 --- cl-soap/src/xsd.lisp:1.16 Tue Sep 27 18:25:17 2005 +++ cl-soap/src/xsd.lisp Tue Sep 27 20:22:53 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.16 2005/09/27 16:25:17 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.17 2005/09/27 18:22:53 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -73,71 +73,60 @@ ;;; Parsing +(defun handle-lxml-schema-elements (children-mixin lxml) + (loop :for child :in (lxml-get-children lxml) + :do (push (lxml->schema-element child) + (get-children children-mixin))) + (setf (get-children children-mixin) (nreverse (get-children children-mixin)))) + (defun lxml->schema-element (lxml) - (case (lxml-get-tag lxml) - (xsd:|element| - (let* ((attributes (lxml-get-attributes lxml)) - (name (getf attributes :|name|)) - (type (getf attributes :|type|)) - (min-occurs (getf attributes :|minOccurs|)) - (max-occurs (getf attributes :|maxOccurs|)) - (nillable (getf attributes :|nillable|)) - (xml-schema-element (make-instance 'xml-schema-element - :name name - :type type - :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)) - 1) - :nillable (equal nillable "true")))) - (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|)) - (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|)) - (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:|complexContent| - (let* ((xsd-complex-content (make-instance 'xsd-complex-content))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xsd-complex-content))) - xsd-complex-content)) - (xsd:|restriction| - (let* ((attributes (lxml-get-attributes lxml)) - (base (getf attributes :|base|)) - (xsd-restriction (make-instance 'xsd-restriction :base base))) - xsd-restriction)) - (xsd:|extension| - (let* ((attributes (lxml-get-attributes lxml)) - (base (getf attributes :|base|)) - (xsd-extension (make-instance 'xsd-extension :base base))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xsd-extension))) - xsd-extension)) - (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)))) + (let ((attributes (lxml-get-attributes lxml))) + (case (lxml-get-tag lxml) + (xsd:|element| + (let* ((name (getf attributes :|name|)) + (type (getf attributes :|type|)) + (min-occurs (getf attributes :|minOccurs|)) + (max-occurs (getf attributes :|maxOccurs|)) + (nillable (getf attributes :|nillable|)) + (xml-schema-element (make-instance 'xml-schema-element + :name name + :type type + :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)) + 1) + :nillable (equal nillable "true")))) + (handle-lxml-schema-elements xml-schema-element lxml) + xml-schema-element)) + (xsd:|simpleType| + (let* ((name (getf attributes :|name|)) + (xsd-type (make-instance 'xsd-simple-type :name name))) + (handle-lxml-schema-elements xsd-type lxml) + xsd-type)) + (xsd:|complexType| + (let* ((name (getf attributes :|name|)) + (xsd-type (make-instance 'xsd-complex-type :name name))) + (handle-lxml-schema-elements xsd-type lxml) + xsd-type)) + (xsd:|complexContent| + (let ((xsd-complex-content (make-instance 'xsd-complex-content))) + (handle-lxml-schema-elements xsd-complex-content lxml) + xsd-complex-content)) + (xsd:|restriction| + (let* ((base (getf attributes :|base|)) + (xsd-restriction (make-instance 'xsd-restriction :base base))) + xsd-restriction)) + (xsd:|extension| + (let* ((base (getf attributes :|base|)) + (xsd-extension (make-instance 'xsd-extension :base base))) + (handle-lxml-schema-elements xsd-extension lxml) + xsd-extension)) + (xsd:|sequence| + (let ((xsd-sequence (make-instance 'xsd-sequence))) + (handle-lxml-schema-elements xsd-sequence lxml) + xsd-sequence))))) (defun lxml->schema-definition (lxml) (if (eql (lxml-get-tag lxml) 'xsd:|schema|) From scaekenberghe at common-lisp.net Tue Sep 27 20:28:36 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 27 Sep 2005 22:28:36 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: public_html/google-adwords-api.html public_html/index.html Message-ID: <20050927202836.35A8588558@common-lisp.net> Update of /project/cl-soap/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv766 Modified Files: index.html Added Files: google-adwords-api.html Log Message: more documentation Date: Tue Sep 27 22:28:33 2005 Author: scaekenberghe Index: public_html/index.html diff -u public_html/index.html:1.6 public_html/index.html:1.7 --- public_html/index.html:1.6 Thu Sep 22 22:40:44 2005 +++ public_html/index.html Tue Sep 27 22:28:32 2005 @@ -75,6 +75,8 @@

Status

+ Currently, phase 1 (and then some) has been implemented. +

S-XML was extended to support XML Namespaces

Basic, manual SOAP calls are now possible, for example: @@ -120,7 +122,13 @@ "getRate" :input `("country1" ,country1 "country2" ,country2)))
-
Some partial support for XML Schema Defintion types definition in WSDL is being implemented.
+
Https support in http-client.lisp was added for LispWorks
+
The general function soap-call was extended to handle headers (input and output headers)
+
The function wsdl-soap-call now handles document based SOAP calls too
+
Partial support for XML Schema Defintion types definition in WSDL has been implemented
+
The target of being able to talk to the Google AdWords API has been reached! + A separate document, Google AdWords API describes this in more detail + and with some verbose examples

Lot's of work remains to be done! All help is welcome.

@@ -162,6 +170,6 @@ Initial developers and contributors will include Sven Van Caekenberghe (Beta Nine), Alain Picard (Memetrics), Ivan Melotte (Beta Nine) and Nicky Peeters (Beta Nine).
-
$Id: index.html,v 1.6 2005/09/22 20:40:44 scaekenberghe Exp $
+
$Id: index.html,v 1.7 2005/09/27 20:28:32 scaekenberghe Exp $
From scaekenberghe at common-lisp.net Tue Sep 27 20:35:17 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Tue, 27 Sep 2005 22:35:17 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: public_html/google-adwords-api.html Message-ID: <20050927203517.E7DB388561@common-lisp.net> Update of /project/cl-soap/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv1775 Modified Files: google-adwords-api.html Log Message: layout Date: Tue Sep 27 22:35:17 2005 Author: scaekenberghe Index: public_html/google-adwords-api.html diff -u public_html/google-adwords-api.html:1.1 public_html/google-adwords-api.html:1.2 --- public_html/google-adwords-api.html:1.1 Tue Sep 27 22:28:32 2005 +++ public_html/google-adwords-api.html Tue Sep 27 22:35:16 2005 @@ -36,10 +36,10 @@ Operation: getUnitCountForMethod Input: getUnitCountForMethodRequest Element "getUnitCountForMethod" [required] - Member "service" of primitive type "string"[ required] - Member "method" of primitive type "string"[ required] - Member "startDate" of primitive type "date"[ required] - Member "endDate" of primitive type "date"[ required] + Member "service" of primitive type "string" [required] + Member "method" of primitive type "string" [required] + Member "startDate" of primitive type "date" [required] + Member "endDate" of primitive type "date" [required] <getUnitCountForMethod> <service>string</service> <method>string</method> @@ -48,31 +48,31 @@ </getUnitCountForMethod> Output: getUnitCountForMethodResponse Element "getUnitCountForMethodResponse" [required] - Member "getUnitCountForMethodReturn" of primitive type "long"[ required] + Member "getUnitCountForMethodReturn" of primitive type "long" [required] <getUnitCountForMethodResponse> <getUnitCountForMethodReturn>long</getUnitCountForMethodReturn> </getUnitCountForMethodResponse> Operation: getUnitCount Input: getUnitCountRequest Element "getUnitCount" [required] - Member "startDate" of primitive type "date"[ required] - Member "endDate" of primitive type "date"[ required] + Member "startDate" of primitive type "date" [required] + Member "endDate" of primitive type "date" [required] <getUnitCount> <startDate>date</startDate> <endDate>date</endDate> </getUnitCount> Output: getUnitCountResponse Element "getUnitCountResponse" [required] - Member "getUnitCountReturn" of primitive type "long"[ required] + Member "getUnitCountReturn" of primitive type "long" [required] <getUnitCountResponse> <getUnitCountReturn>long</getUnitCountReturn> </getUnitCountResponse> Operation: getMethodCost Input: getMethodCostRequest Element "getMethodCost" [required] - Member "service" of primitive type "string"[ required] - Member "method" of primitive type "string"[ required] - Member "date" of primitive type "date"[ required] + Member "service" of primitive type "string" [required] + Member "method" of primitive type "string" [required] + Member "date" of primitive type "date" [required] <getMethodCost> <service>string</service> <method>string</method> @@ -80,7 +80,7 @@ </getMethodCost> Output: getMethodCostResponse Element "getMethodCostResponse" [required] - Member "getMethodCostReturn" of primitive type "int"[ required] + Member "getMethodCostReturn" of primitive type "int" [required] <getMethodCostResponse> <getMethodCostReturn>int</getMethodCostReturn> </getMethodCostResponse> @@ -91,7 +91,7 @@ </getUsageQuotaThisMonth> Output: getUsageQuotaThisMonthResponse Element "getUsageQuotaThisMonthResponse" [required] - Member "getUsageQuotaThisMonthReturn" of primitive type "long"[ required] + Member "getUsageQuotaThisMonthReturn" of primitive type "long" [required] <getUsageQuotaThisMonthResponse> <getUsageQuotaThisMonthReturn>long</getUsageQuotaThisMonthReturn> </getUsageQuotaThisMonthResponse> @@ -102,22 +102,22 @@ </getOperationsQuotaThisMonth> Output: getOperationsQuotaThisMonthResponse Element "getOperationsQuotaThisMonthResponse" [required] - Member "getOperationsQuotaThisMonthReturn" of primitive type "long"[ required] + Member "getOperationsQuotaThisMonthReturn" of primitive type "long" [required] <getOperationsQuotaThisMonthResponse> <getOperationsQuotaThisMonthReturn>long</getOperationsQuotaThisMonthReturn> </getOperationsQuotaThisMonthResponse> Operation: getOperationCount Input: getOperationCountRequest Element "getOperationCount" [required] - Member "startDate" of primitive type "date"[ required] - Member "endDate" of primitive type "date"[ required] + Member "startDate" of primitive type "date" [required] + Member "endDate" of primitive type "date" [required] <getOperationCount> <startDate>date</startDate> <endDate>date</endDate> </getOperationCount> Output: getOperationCountResponse Element "getOperationCountResponse" [required] - Member "getOperationCountReturn" of primitive type "long"[ required] + Member "getOperationCountReturn" of primitive type "long" [required] <getOperationCountResponse> <getOperationCountReturn>long</getOperationCountReturn> </getOperationCountResponse> @@ -205,6 +205,6 @@ Note that two values are returned: the actual value and the headers. Stay tuned for more complicated examples later on.
-
$Id: google-adwords-api.html,v 1.1 2005/09/27 20:28:32 scaekenberghe Exp $
+
$Id: google-adwords-api.html,v 1.2 2005/09/27 20:35:16 scaekenberghe Exp $
From scaekenberghe at common-lisp.net Wed Sep 28 09:00:55 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Wed, 28 Sep 2005 11:00:55 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050928090055.34E5B88549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv21182/src Modified Files: xsd.lisp Log Message: fixed a typo Date: Wed Sep 28 11:00:54 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.17 cl-soap/src/xsd.lisp:1.18 --- cl-soap/src/xsd.lisp:1.17 Tue Sep 27 20:22:53 2005 +++ cl-soap/src/xsd.lisp Wed Sep 28 11:00:51 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.17 2005/09/27 18:22:53 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.18 2005/09/28 09:00:51 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -529,7 +529,7 @@ (member-type (get-type member))) (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format stream " Member ~s of primitive type ~s[ ~a]~@[ nillable~]~%" + (format stream " Member ~s of primitive type ~s [~a]~@[ nillable~]~%" member-name member-type (describe-multiplicity member) (get-nillable member)) (progn (format stream " Member ~s [~a]~@[ nillable~]~%" member-name From scaekenberghe at common-lisp.net Wed Sep 28 09:26:12 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Wed, 28 Sep 2005 11:26:12 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp Message-ID: <20050928092612.53D1188549@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv22719/test Modified Files: test-google-adwords.lisp Log Message: updated test code Date: Wed Sep 28 11:26:11 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.11 cl-soap/test/test-google-adwords.lisp:1.12 --- cl-soap/test/test-google-adwords.lisp:1.11 Tue Sep 27 18:25:18 2005 +++ cl-soap/test/test-google-adwords.lisp Wed Sep 28 11:26:11 2005 @@ -1,8 +1,8 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.11 2005/09/27 16:25:18 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.12 2005/09/28 09:26:11 scaekenberghe Exp $ ;;;; -;;;; Some test on the Google AdWords API (not publically available) +;;;; Some tests on the Google AdWords API (not publically available) ;;;; ;;;; Copyright (C) 2005 Sven Van Caekenberghe, Beta Nine BVBA. All Rights Reserved. ;;;; @@ -13,15 +13,7 @@ (in-package :cl-soap) -;;; account parameters - -(defvar *google-adwords-email*) -(defvar *google-adwords-password*) -(defvar *google-adwords-user-agent*) -(defvar *google-adwords-token*) -(defvar *google-client-email*) - -;;; constants +;;; XML namespaces setup (defconstant +google-adwords-ns-uri+ "https://adwords.google.com/api/adwords/v2") @@ -32,18 +24,19 @@ "email" "password" "useragent" "token" "clientEmail" ;; info service "getUsageQuotaThisMonth" "getUsageQuotaThisMonthResponse" "getUsageQuotaThisMonthReturn" - "getCampaigns" "getCampaign" "getBillingAddress") + "getCampaigns" "getCampaign" "getBillingAddress" + ;; optionally add more exports, but this is not really needed for wsdl-soap-call's + ) (: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 +;;; *************************************************************************************** +;;; apparently there are different XML Schema Defintion namespace URIs, Google is using (s-xml:register-namespace "http://www.w3.org/2001/XMLSchema" "xsd" :xsd) -;;; **************************************************************************************** +;;; *************************************************************************************** + +;;; basic WSDL parsing (defparameter *google-adwords-api-wsdl-urls* (loop :for service :in '("CreativeService" @@ -59,6 +52,26 @@ (defun parse-all-wsdl () (mapcar #'parse-wsdl-url *google-adwords-api-wsdl-urls*)) +;;; account parameters + +(defvar *google-adwords-email*) +(defvar *google-adwords-password*) +(defvar *google-adwords-user-agent*) +(defvar *google-adwords-token*) +(defvar *google-client-email*) + +(defun make-google-headers (&key + (email *google-adwords-email*) + (password *google-adwords-password*) + (user-agent *google-adwords-user-agent*) + (token *google-adwords-token*) + (client-email *google-client-email*)) + `("email" ,email + "password" ,password + "useragent" ,user-agent + "token" ,token + "clientEmail" ,client-email)) + ;;; some test calls #+NIL @@ -81,11 +94,7 @@ (defun get-usage-quota-this-month () (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*))) + :headers (make-google-headers))) #+NIL (defun get-method-cost (service method &optional (date (ut))) @@ -113,11 +122,7 @@ :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*))) + :headers (make-google-headers))) #+NIL (defun get-operation-count (start-date &optional (end-date start-date))) @@ -127,11 +132,7 @@ "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*))) + :headers (make-google-headers))) #+NIL (defun get-unit-count-for-method (service method &optional (start-date (ut)) (end-date start-date))) @@ -165,15 +166,11 @@ :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) (values result headers))) -(defun get-all-adwords-campaigns (client-email) +(defun get-all-adwords-campaigns (&optional (client-email *google-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))) + :headers (make-google-headers :client-email client-email))) #+NIL (defun get-campaign (id client-email) @@ -219,21 +216,13 @@ 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*))) + :headers (make-google-headers))) (defun get-all-adgroups (campaign-id) (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl") "getAllAdGroups" :input `("campaignID" ,campaign-id) - :headers `("email" ,*google-adwords-email* - "password" ,*google-adwords-password* - "useragent" ,*google-adwords-user-agent* - "token" ,*google-adwords-token* - "clientEmail" ,*google-client-email*))) + :headers (make-google-headers))) (defun add-campaign (client-email daily-budget status &key name language-targeting geo-targeting) ;; to be completed @@ -241,11 +230,7 @@ "addCampaign" ;; input placeholder !! :input `(,daily-budget ,status name ,name ,language-targeting ,geo-targeting) - :headers `("email" ,*google-adwords-email* - "password" ,*google-adwords-password* - "useragent" ,*google-adwords-user-agent* - "token" ,*google-adwords-token* - "clientEmail" ,client-email))) + :headers (make-google-headers :client-email client-email))) (defun schedule-report-job (client-email report-job) ;; to be completed @@ -253,10 +238,26 @@ "scheduleReportJob" ;; input placeholder !! :input `(,report-job) - :headers `("email" ,*google-adwords-email* - "password" ,*google-adwords-password* - "useragent" ,*google-adwords-user-agent* - "token" ,*google-adwords-token* - "clientEmail" ,client-email))) + :headers (make-google-headers :client-email client-email))) + +(defun make-ad-group (&key max-cpc max-cpm name (status "Enabled") (id -1) (campaign-id -1)) + (let (fields) + (when max-cpc + (push `("maxCpc" ,max-cpc) fields)) + (when max-cpm + (push `("maxCpm" ,max-cpm) fields)) + (push `("name" ,name) fields) + (push `("status" ,status) fields) + (push `("id" ,id) fields) + (push `("campaignId" ,campaign-id) fields) + (apply #'append fields))) + +(defun add-ad-group (campaign-id new-data) + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl") + "addAdGroup" + :input + `("campaignID" ,campaign-id "AdGroup" ,new-data) + :headers + (make-google-headers))) ;;;; eof From scaekenberghe at common-lisp.net Fri Sep 30 17:12:22 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 19:12:22 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp cl-soap/test/test-xsd.lisp Message-ID: <20050930171222.06942880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv30515/test Modified Files: test-google-adwords.lisp test-xsd.lisp Log Message: first version of xsd bind-element/resolve-element based on the new concept of 'xsd templates' - so far input/output symmetry has been reached and initial testing looks good; awaits further/more/deeper testing and some more cleanup/integration Date: Fri Sep 30 19:12:21 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.12 cl-soap/test/test-google-adwords.lisp:1.13 --- cl-soap/test/test-google-adwords.lisp:1.12 Wed Sep 28 11:26:11 2005 +++ cl-soap/test/test-google-adwords.lisp Fri Sep 30 19:12:20 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.12 2005/09/28 09:26:11 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.13 2005/09/30 17:12:20 scaekenberghe Exp $ ;;;; ;;;; Some tests on the Google AdWords API (not publically available) ;;;; @@ -19,14 +19,6 @@ (defpackage :google (:nicknames "google") - (:export - ;; headers - "email" "password" "useragent" "token" "clientEmail" - ;; info service - "getUsageQuotaThisMonth" "getUsageQuotaThisMonthResponse" "getUsageQuotaThisMonthReturn" - "getCampaigns" "getCampaign" "getBillingAddress" - ;; optionally add more exports, but this is not really needed for wsdl-soap-call's - ) (: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)) @@ -74,154 +66,46 @@ ;;; 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") - `((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 - (values (parse-integer (second contents)) headers) - (error "Expected a element"))) - (error "Expected a element")))) - (defun get-usage-quota-this-month () (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl") "getUsageQuotaThisMonth" :headers (make-google-headers))) -#+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") - `((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 element"))) - (error "Expected a element")))) - (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" - :input `("service" ,service - "method" ,method - "date" ,date) + :input `("getMethodCost" ("service" ,service "method" ,method "date" ,date)) :headers (make-google-headers))) -#+NIL -(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 (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/InfoService?wsdl") "getUnitCount" - :input `("startDate" ,start-date - "endDate" ,end-date) + :input `("getUnitCount" ("startDate" ,start-date "endDate" ,end-date)) :headers (make-google-headers))) -#+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") - `((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 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") - `((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-all-adwords-campaigns (&optional (client-email *google-client-email*)) (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl") "getAllAdWordsCampaigns" - :input '("dummy" 1) + :input '("getAllAdWordsCampaigns" ("dummy" 1)) :headers (make-google-headers :client-email 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") - `((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))) - -#+NIL -(defun estimate-keyword-list (keywords) - "(( )*) 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) "(( )*) where type is Broad|Phrase|Exact" (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) - keyword - `("KeywordRequest" ("text" ,text "type" ,type "maxCpc" ,max-cpc)))) - keywords) + :input `("estimateKeywordList" + ("keywordRequests" + ,(mapcar #'(lambda (keyword) + (destructuring-bind (text type max-cpc) + keyword + `("text" ,text "type" ,type "maxCpc" ,max-cpc))) + keywords))) :headers (make-google-headers))) (defun get-all-adgroups (campaign-id) (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl") "getAllAdGroups" - :input `("campaignID" ,campaign-id) + :input `("getAllAdGroups" ("campaignID" ,campaign-id)) :headers (make-google-headers))) (defun add-campaign (client-email daily-budget status &key name language-targeting geo-targeting) @@ -256,7 +140,23 @@ (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl") "addAdGroup" :input - `("campaignID" ,campaign-id "AdGroup" ,new-data) + `("addAdGroup" ("campaignID" ,campaign-id "newData" ,new-data)) + :headers + (make-google-headers))) + +(defun update-ad-group (changed-data) + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl") + "updateAdGroup" + :input + `("updateAdGroup" ("changedData" ,changed-data)) + :headers + (make-google-headers))) + +(defun get-ad-group (id) + (wsdl-soap-call (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl") + "getAdGroup" + :input + `("getAdGroup" ("adGroupId" ,id)) :headers (make-google-headers))) Index: cl-soap/test/test-xsd.lisp diff -u cl-soap/test/test-xsd.lisp:1.1 cl-soap/test/test-xsd.lisp:1.2 --- cl-soap/test/test-xsd.lisp:1.1 Tue Sep 27 18:25:18 2005 +++ cl-soap/test/test-xsd.lisp Fri Sep 30 19:12:20 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-xsd.lisp,v 1.1 2005/09/27 16:25:18 scaekenberghe Exp $ +;;;; $Id: test-xsd.lisp,v 1.2 2005/09/30 17:12:20 scaekenberghe Exp $ ;;;; ;;;; Some (internal) test on the implementatin of the XML Schema Definition ;;;; @@ -11,9 +11,10 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; +(in-package :cl-soap) + (let ((schema (get-xml-schema-definition (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl"))) - (namespace (s-xml:find-namespace "https://adwords.google.com/api/adwords/v2")) (lxml '((GOOGLE::|getAllAdWordsCampaignsResponse| :|xmlns| "https://adwords.google.com/api/adwords/v2") (GOOGLE::|getAllAdWordsCampaignsReturn| (GOOGLE::|dailyBudget| "200000000") @@ -36,59 +37,14 @@ (GOOGLE::|optInSearchNetwork| "true") (GOOGLE::|optInContentNetwork| "true") (GOOGLE::|languageTargeting| (GOOGLE::|languages| "en")) - (GOOGLE::|geoTargeting| (GOOGLE::|countries| "AU"))) - (GOOGLE::|getAllAdWordsCampaignsReturn| - (GOOGLE::|dailyBudget| "10000") - (GOOGLE::|id| "5614005") - (GOOGLE::|name| "Campaign #4") - (GOOGLE::|status| "Deleted") - (GOOGLE::|startDate| "2005-09-14T07:24:05.000Z") - (GOOGLE::|endDate| "2005-09-14T07:24:52.000Z") - (GOOGLE::|optInSearchNetwork| "false") - (GOOGLE::|optInContentNetwork| "false") - ((GOOGLE::|languageTargeting| XSI:|null| "true")) - ((GOOGLE::|geoTargeting| XSI:|null| "true"))) - (GOOGLE::|getAllAdWordsCampaignsReturn| - (GOOGLE::|dailyBudget| "10000") - (GOOGLE::|id| "5614035") - (GOOGLE::|name| "Campaign #5") - (GOOGLE::|status| "Deleted") - (GOOGLE::|startDate| "2005-09-14T07:30:44.000Z") - (GOOGLE::|endDate| "2005-09-14T07:34:13.000Z") - (GOOGLE::|optInSearchNetwork| "false") - (GOOGLE::|optInContentNetwork| "false") - ((GOOGLE::|languageTargeting| XSI:|null| "true")) - ((GOOGLE::|geoTargeting| XSI:|null| "true"))) - (GOOGLE::|getAllAdWordsCampaignsReturn| - (GOOGLE::|dailyBudget| "10000") - (GOOGLE::|id| "5628855") - (GOOGLE::|name| "Campaign #6") - (GOOGLE::|status| "Deleted") - (GOOGLE::|startDate| "2005-09-16T05:42:20.000Z") - (GOOGLE::|endDate| "2005-09-16T05:43:24.000Z") - (GOOGLE::|optInSearchNetwork| "false") - (GOOGLE::|optInContentNetwork| "false") - ((GOOGLE::|languageTargeting| XSI:|null| "true")) - ((GOOGLE::|geoTargeting| XSI:|null| "true"))) - (GOOGLE::|getAllAdWordsCampaignsReturn| - (GOOGLE::|dailyBudget| "10000") - (GOOGLE::|id| "5634135") - (GOOGLE::|name| "Campaign #7") - (GOOGLE::|status| "Deleted") - (GOOGLE::|startDate| "2005-09-16T20:06:15.000Z") - (GOOGLE::|endDate| "2005-09-16T20:22:51.000Z") - (GOOGLE::|optInSearchNetwork| "false") - (GOOGLE::|optInContentNetwork| "false") - ((GOOGLE::|languageTargeting| XSI:|null| "true")) - ((GOOGLE::|geoTargeting| XSI:|null| "true")))))) + (GOOGLE::|geoTargeting| (GOOGLE::|countries| "AU")))))) (pprint (resolve-element "getAllAdWordsCampaignsResponse" lxml schema - namespace))) + *google-adwords-ns*))) (let ((schema (get-xml-schema-definition (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/AdGroupService?wsdl"))) - (namespace (s-xml:find-namespace "https://adwords.google.com/api/adwords/v2")) (lxml '((GOOGLE::|getAllAdGroupsResponse| :|xmlns| "https://adwords.google.com/api/adwords/v2") (GOOGLE::|getAllAdGroupsReturn| (GOOGLE::|maxCpc| "8000000") @@ -127,324 +83,6 @@ (GOOGLE::|campaignId| "3871365") (GOOGLE::|status| "Deleted")) (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Lifestyle Financial Planning") - (GOOGLE::|id| "200452095") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Multi-Manager Investments") - (GOOGLE::|id| "200452125") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "12200000") - (GOOGLE::|name| "Planning Retirement") - (GOOGLE::|id| "200452215") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Planning my Investments") - (GOOGLE::|id| "200452245") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Reasonable Benefit Limit") - (GOOGLE::|id| "200452275") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "6560000") - (GOOGLE::|name| "Redundancy Advice") - (GOOGLE::|id| "200452305") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "5390000") - (GOOGLE::|name| "Retirement Advice") - (GOOGLE::|id| "200452335") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Retrenchment Advice") - (GOOGLE::|id| "200452365") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "1610000") - (GOOGLE::|name| "Salary Sacrifice") - (GOOGLE::|id| "200452395") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "3570000") - (GOOGLE::|name| "Superannuation") - (GOOGLE::|id| "200452485") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Superannuation Surcharge") - (GOOGLE::|id| "200452515") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "33240000") - (GOOGLE::|name| "Tax Advice") - (GOOGLE::|id| "200452575") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "7520000") - (GOOGLE::|name| "Tax Planning") - (GOOGLE::|id| "200452635") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "26910000") - (GOOGLE::|name| "Financial Advisor") - (GOOGLE::|id| "200452665") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "12980000") - (GOOGLE::|name| "Financial Planner") - (GOOGLE::|id| "200452695") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "1290000") - (GOOGLE::|name| "Tax Tips") - (GOOGLE::|id| "200902695") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "5510000") - (GOOGLE::|name| "Financial Assistance") - (GOOGLE::|id| "200902815") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "43750000") - (GOOGLE::|name| "Independent Financial Advisor") - (GOOGLE::|id| "200902845") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "2930000") - (GOOGLE::|name| "tax information") - (GOOGLE::|id| "200902875") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "3660000") - (GOOGLE::|name| "Planners") - (GOOGLE::|id| "200902905") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "4020000") - (GOOGLE::|name| "planning") - (GOOGLE::|id| "200902935") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "500000") - (GOOGLE::|name| "Australian Financial Planning") - (GOOGLE::|id| "200902995") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Deleted")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "8040000") - (GOOGLE::|name| "1. Financial Planning (new)") - (GOOGLE::|id| "202802655") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Retrenchment Advice (new)") - (GOOGLE::|id| "202802715") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "6540000") - (GOOGLE::|name| "1. Redundancy Advice (new)") - (GOOGLE::|id| "202802775") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Investing Super (new)") - (GOOGLE::|id| "202802805") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Super (new)") - (GOOGLE::|id| "202802865") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Lifestyle Financial Planning (new)") - (GOOGLE::|id| "202802895") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "Multi-Manager Investments (new)") - (GOOGLE::|id| "202802955") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "5370000") - (GOOGLE::|name| "1. Retirement Advice (new)") - (GOOGLE::|id| "202803075") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Planning my Investments (new)") - (GOOGLE::|id| "202803135") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "10520000") - (GOOGLE::|name| "Investment Advice (new)") - (GOOGLE::|id| "202803165") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Investment Guidance (new)") - (GOOGLE::|id| "202803225") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "5500000") - (GOOGLE::|name| "1. Financial Assistance (new)") - (GOOGLE::|id| "202803285") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "3230000") - (GOOGLE::|name| "1. Career Transition (new)") - (GOOGLE::|id| "202803315") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Planning Seminars (new)") - (GOOGLE::|id| "202803345") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "4600000") - (GOOGLE::|name| "1. Financial Tips (new)") - (GOOGLE::|id| "202803375") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "2430000") - (GOOGLE::|name| "1. Money Tips (new)") - (GOOGLE::|id| "202803405") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "200000") - (GOOGLE::|name| "1. Super Tips (new)") - (GOOGLE::|id| "202803435") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "11750000") - (GOOGLE::|name| "1. Investment Tips (new)") - (GOOGLE::|id| "202803465") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "4020000") - (GOOGLE::|name| "1. planning (new)") - (GOOGLE::|id| "202803645") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Reasonable Benefit Limit (new)") - (GOOGLE::|id| "202803705") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "90000") - (GOOGLE::|name| "1. Superannuation Surcharge (new)") - (GOOGLE::|id| "202803735") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "33120000") - (GOOGLE::|name| "1. Tax Advice (new)") - (GOOGLE::|id| "202803765") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "5420000") - (GOOGLE::|name| "1. Financial Plan (new)") - (GOOGLE::|id| "202803825") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "3560000") - (GOOGLE::|name| "1. Superannuation (new)") - (GOOGLE::|id| "202803855") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "3560000") - (GOOGLE::|name| "1. Diversified Fund (new)") - (GOOGLE::|id| "202803885") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "26820000") - (GOOGLE::|name| "1. Financial Advisor (new)") - (GOOGLE::|id| "202803915") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "150000") - (GOOGLE::|name| "ETP (new)") - (GOOGLE::|id| "202803945") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "7490000") - (GOOGLE::|name| "1. Tax Planning (new)") - (GOOGLE::|id| "202803975") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "12930000") - (GOOGLE::|name| "1. Financial Planner (new)") - (GOOGLE::|id| "202804005") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "12160000") - (GOOGLE::|name| "Retirement Planning") - (GOOGLE::|id| "202804035") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| - (GOOGLE::|maxCpc| "2930000") - (GOOGLE::|name| "1. Tax Information (new)") - (GOOGLE::|id| "202804095") - (GOOGLE::|campaignId| "3871365") - (GOOGLE::|status| "Enabled")) - (GOOGLE::|getAllAdGroupsReturn| (GOOGLE::|maxCpc| "43730000") (GOOGLE::|name| "1.Independent Financial Advisor (new)") (GOOGLE::|id| "202804125") @@ -453,6 +91,111 @@ (pprint (resolve-element "getAllAdGroupsResponse" lxml schema - namespace))) + *google-adwords-ns*))) + +(let ((schema (get-xml-schema-definition + (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl"))) + (lxml '((GOOGLE:|getAllAdWordsCampaignsResponse| :|xmlns| "https://adwords.google.com/api/adwords/v2") + (GOOGLE:|getAllAdWordsCampaignsReturn| + (GOOGLE:|dailyBudget| "1000000") + (GOOGLE:|id| "5631435") + (GOOGLE:|name| "Campaign #1") + (GOOGLE:|status| "Active") + (GOOGLE:|startDate| "2005-09-16T11:11:14.000Z") + (GOOGLE:|endDate| "2011-01-01T07:59:59.000Z") + (GOOGLE:|optInSearchNetwork| "true") + (GOOGLE:|optInContentNetwork| "true") + (GOOGLE:|languageTargeting| (GOOGLE:|languages| "en") (GOOGLE:|languages| "nl")) + (GOOGLE:|geoTargeting| (GOOGLE:|countries| "BE") (GOOGLE:|countries| "NL")))))) + (pprint (resolve-element "getAllAdWordsCampaignsResponse" + lxml + schema + *google-adwords-ns*))) + +(let ((schema (get-xml-schema-definition + (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl"))) + (binding '("id" + 5631435 + "name" + "Campaign #1" + "status" + "Active" + "startDate" + 3335857874 + "endDate" + 3502857599 + "dailyBudget" + 1000000 + "optInSearchNetwork" + T + "optInContentNetwork" + T + "languageTargeting" + (("languages" "en") ("languages" "nl")) + "geoTargeting" + (("countries" "BE") ("countries" "NL"))))) + (pprint (bind-type "Campaign" + binding + nil + schema + *google-adwords-ns*))) + +(let ((schema (get-xml-schema-definition + (wsdl-cache-get"https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl"))) + (binding `("estimateKeywordList" + ("keywordRequests" + ,(mapcar #'(lambda (keyword) + (destructuring-bind (text type max-cpc) + keyword + `("text" ,text "type" ,type "maxCpc" ,max-cpc))) + '(("flowers" "Broad" 50000) ("tree" "Broad" 100000))))))) + (pprint (bind-element "estimateKeywordList" + binding + schema + *google-adwords-ns*))) + +(let ((schema (get-xml-schema-definition + (wsdl-cache-get"https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl"))) + (binding '("text" "flowers" "type" "Broad" "maxCpc" 50000))) + (pprint (bind-type "KeywordRequest" + binding + nil + schema + *google-adwords-ns*))) + +(defun test-1 () + (let* ((schema (get-xml-schema-definition + (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl"))) + (template (generate-xsd-template "estimateKeywordList" schema)) + (binding `("estimateKeywordList" + ("keywordRequests" + ,(mapcar #'(lambda (keyword) + (destructuring-bind (text type max-cpc) + keyword + `("text" ,text "type" ,type "maxCpc" ,max-cpc))) + '(("flowers" "Broad" 50000) ("tree" "Broad" 100000))))))) + (bind-xsd-template template + binding + *google-adwords-ns*))) + +(defun test-2 () + (let* ((schema (get-xml-schema-definition + (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl"))) + (template (generate-xsd-template "getAllAdWordsCampaignsResponse" schema)) + (lxml '((GOOGLE::|getAllAdWordsCampaignsResponse| :|xmlns| "https://adwords.google.com/api/adwords/v2") + (GOOGLE::|getAllAdWordsCampaignsReturn| + (GOOGLE::|dailyBudget| "1000000") + (GOOGLE::|id| "5631435") + (GOOGLE::|name| "Campaign #1") + (GOOGLE::|status| "Active") + (GOOGLE::|startDate| "2005-09-16T11:11:14.000Z") + (GOOGLE::|endDate| "2011-01-01T07:59:59.000Z") + (GOOGLE::|optInSearchNetwork| "true") + (GOOGLE::|optInContentNetwork| "true") + (GOOGLE::|languageTargeting| (GOOGLE::|languages| "en") (GOOGLE::|languages| "nl")) + (GOOGLE::|geoTargeting| (GOOGLE::|countries| "BE") (GOOGLE::|countries| "NL")))))) + (resolve-xsd-template template + (list lxml) + *google-adwords-ns*))) ;;;; eof From scaekenberghe at common-lisp.net Fri Sep 30 17:12:21 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 19:12:21 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/development.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp Message-ID: <20050930171221.3F410880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv30515/src Modified Files: development.lisp wsdl.lisp xsd.lisp Log Message: first version of xsd bind-element/resolve-element based on the new concept of 'xsd templates' - so far input/output symmetry has been reached and initial testing looks good; awaits further/more/deeper testing and some more cleanup/integration Date: Fri Sep 30 19:12:18 2005 Author: scaekenberghe Index: cl-soap/src/development.lisp diff -u cl-soap/src/development.lisp:1.1 cl-soap/src/development.lisp:1.2 --- cl-soap/src/development.lisp:1.1 Mon Sep 5 10:35:55 2005 +++ cl-soap/src/development.lisp Fri Sep 30 19:12:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: development.lisp,v 1.1 2005/09/05 08:35:55 scaekenberghe Exp $ +;;;; $Id: development.lisp,v 1.2 2005/09/30 17:12:17 scaekenberghe Exp $ ;;;; ;;;; Development scratch pad ;;;; @@ -22,5 +22,307 @@ (: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)) + +;;; Older Manual Google AdWords Calls + +(export + '(;; headers + "email" "password" "useragent" "token" "clientEmail" + ;; info service + "getUsageQuotaThisMonth" "getUsageQuotaThisMonthResponse" "getUsageQuotaThisMonthReturn" + "getCampaigns" "getCampaign" "getBillingAddress" + ;; optionally add more exports, but this is not really needed for wsdl-soap-call's + )) + +(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*) + (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 + (values (parse-integer (second contents)) headers) + (error "Expected a element"))) + (error "Expected a element")))) + +(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 element"))) + (error "Expected a element")))) + +(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 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 estimate-keyword-list (keywords) + "(( )*) 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 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))) + +;; Moved code + +(defun binding-primitive-value (name type bindings) + (let ((value (get-name-binding name bindings))) + (when value + (lisp->xsd-primitive value (intern-xsd-type-name type))))) + +(defun bind-primitive (element type-name bindings namespace) + (let ((value (binding-primitive-value (get-name element) type-name bindings))) + (if value + `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) + (if (is-optional-p element) + nil + (error "Cannot find binding for ~a" (get-name element)))))) + +(defun bind-type (type-spec bindings super-element xml-schema-definition namespace) + (let* ((type-element (if (stringp type-spec) (get-element-named xml-schema-definition type-spec) type-spec)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type xml-schema-definition)) + (members-actual-bindings '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for sub-binding :in (get-name-binding member-name bindings) :do + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (bind-primitive member member-type + sub-binding namespace))) + (when member-binding + (incf count) + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (bind-type member-type sub-binding member + xml-schema-definition namespace) + (when bound + (incf count) + (push `(,sub-tag-name , at member-binding) members-actual-bindings))))) + (if (zerop count) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required element <~a> not found" member-name)))) + (let ((sub-binding (get-name-binding member-name bindings))) + (cond ((xsd-primitive-type-name-p member-type) + (let ((member-binding (bind-primitive member member-type + bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings)))) + (t + (multiple-value-bind (member-binding bound) + (bind-type member-type sub-binding member + xml-schema-definition namespace) + (if bound + (push `(,sub-tag-name , at member-binding) members-actual-bindings) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required member ~a not bound" member-name)))))))))) + (values (nreverse members-actual-bindings) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (binding-primitive-value (get-name super-element) type bindings))) + (if value (values (list value) t) (values nil nil))) + (error "Unexpected type"))))) + +(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) + (bind-primitive element element-type bindings namespace)) + ((typep element-type 'xsd-complex-type) + (let ((sub-bindings (get-name-binding (get-name element) bindings)) + (tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if sub-bindings + (multiple-value-bind (members-binding bound) + (bind-type element-type sub-bindings element xml-schema-definition namespace) + (when bound + `(,tag-name , at members-binding))) + (if (or (is-optional-p element) (null (get-members element-type xml-schema-definition))) + tag-name + (error "Element ~a not bound" (get-name element)))))) + (t (error "Cannot bind element ~s of type ~s" element element-type))))) + +(defun lxml-primitive-value (name type lxml namespace) + (let ((tag-name (intern name (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (values (xsd-primitive->lisp (first (lxml-get-children lxml)) (intern-xsd-type-name type)) t) + (values nil nil)))) + +(defun resolve-primitive (element type-name lxml namespace) + (multiple-value-bind (value present) + (lxml-primitive-value (get-name element) type-name lxml namespace) + (if present + (values value t) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" (get-name element)))))) + +(defun resolve-type (type-name lxml super-element xml-schema-definition namespace) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type xml-schema-definition)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push (list member-name member-value) resolved-members))) + (multiple-value-bind (member-value required) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push (list member-name member-value) resolved-members))))) + (if (zerop count) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required element <~a> not found" member-name)))) + (let ((member-lxml (lxml-find-tag sub-tag-name lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) + (values (nreverse resolved-members) t)) + (if (xsd-primitive-type-name-p type) + (lxml-primitive-value (get-name super-element) type lxml namespace) + (error "Unexpected 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) + (resolve-primitive element element-type lxml namespace)) + ((typep element-type 'xsd-complex-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (let ((sub-lxml (lxml-get-children lxml)) + (members (get-members element-type xml-schema-definition)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in sub-lxml :do + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push (list member-name member-value) resolved-members))) + (multiple-value-bind (member-value required) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push (list member-name member-value) resolved-members)))) + (error "Expected a <~a> element" sub-tag-name))) + (if (zerop count) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required element <~a> not found" member-name)))) + (let ((member-lxml (lxml-find-tag sub-tag-name sub-lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) + (values (list (get-name element) (nreverse resolved-members)) t)) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" tag-name))))) + (t (error "Cannot resolve element ~s of type ~s" element element-type))))) ;;;; eof Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.18 cl-soap/src/wsdl.lisp:1.19 --- cl-soap/src/wsdl.lisp:1.18 Mon Sep 26 13:14:55 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 30 19:12:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.18 2005/09/26 11:14:55 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -465,13 +465,11 @@ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) result-values))) (part-element - (multiple-value-bind (value required) - (resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) - (when required - (push value result-values)))) + (let ((part-value (resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace))) + (push part-value result-values))) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) ;; make the common case more handy (if (= (length result-values) 1) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.18 cl-soap/src/xsd.lisp:1.19 --- cl-soap/src/xsd.lisp:1.18 Wed Sep 28 11:00:51 2005 +++ cl-soap/src/xsd.lisp Fri Sep 30 19:12:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.18 2005/09/28 09:00:51 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -191,22 +191,24 @@ (when element (get-type-in-context element (get-elements xml-schema-definition))))) -(defmethod get-members ((xsd-complex-type xsd-complex-type)) +(defmethod get-members ((xsd-complex-type xsd-complex-type) (xml-schema-definition xml-schema-definition)) "Return the list of members of xsd-complex-type, provided it is a sequence or a complex-content (for now)" (let ((first-child (first (get-children xsd-complex-type)))) (cond ((and first-child (typep first-child 'xsd-sequence)) (get-children first-child)) ((and first-child (typep first-child 'xsd-complex-content)) - (get-members first-child))))) + (get-members first-child xml-schema-definition))))) -(defmethod get-members ((xsd-complex-content xsd-complex-content)) +(defmethod get-members ((xsd-complex-content xsd-complex-content) (xml-schema-definition xml-schema-definition)) "Return the list of members of xsd-complex-content, provided it is a base type sequence extension (for now)" (let ((first-child (first (get-children xsd-complex-content)))) (when (and first-child (typep first-child 'xsd-extension)) - (let ((base-members (get-members (get-base first-child))) - (first-child (first (get-children first-child)))) + (let* ((base-type-name (get-base first-child)) + (base-type-element (get-element-named xml-schema-definition base-type-name)) + (base-members (get-members base-type-element xml-schema-definition)) + (first-child (first (get-children first-child)))) (if (and first-child (typep first-child 'xsd-sequence)) - (append base-members (get-members first-child)) + (append base-members (get-children first-child)) base-members))))) (defmethod get-multiplicity ((xml-schema-element xml-schema-element)) @@ -224,219 +226,6 @@ (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 (actual-name name) bindings :test #'equal))) - -(defun binding-primitive-value (name type bindings) - (let ((value (get-name-binding name bindings))) - (when value - (lisp->xsd-primitive value (intern-xsd-type-name type))))) - -(defun bind-primitive (element type-name bindings namespace) - (let ((value (binding-primitive-value (get-name element) type-name bindings))) - (if value - `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) - (if (is-optional-p element) - nil - (error "Cannot find binding for ~a" (get-name element)))))) - -(defun bind-type (type-name bindings super-element xml-schema-definition namespace) - (let* ((type-element (get-element-named xml-schema-definition type-name)) - (type (get-element-type xml-schema-definition type-element))) - (if (typep type 'xsd-complex-type) - (let ((members (get-members type)) - (members-actual-bindings '())) - (loop :for member :in members :do - (let ((member-name (get-name member)) - (member-type (get-type member)) - (sub-bindings (or (get-name-binding (get-name type-element) bindings) - bindings))) - (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (bind-primitive member member-type sub-bindings namespace))) - (when member-binding - (push member-binding members-actual-bindings))) - (multiple-value-bind (member-binding bound) - (bind-type member-type sub-bindings member xml-schema-definition namespace) - (if bound - (push `(,(intern member-name (s-xml:get-package namespace)) - ,member-binding) - members-actual-bindings) - (unless (is-optional-p member) - (error "Required member ~a not bound" member-name))))))) - (values (nreverse members-actual-bindings) t)) - (if (xsd-primitive-type-name-p type) - (let ((value (binding-primitive-value (get-name super-element) type bindings))) - (if value (values value t) (values nil nil))) - (error "unexpected type"))))) - -(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) - (bind-primitive element element-type bindings namespace)) - ((typep element-type 'xsd-complex-type) - (let ((members (get-members element-type)) - (members-actual-bindings '())) - (loop :for member :in members :do - (let* ((member-name (get-name member)) - (member-type (get-type member))) - (if (is-plural-p member) - (let ((count 0)) - (loop :for sub-binding :in bindings :do - (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (bind-primitive member member-type - sub-binding namespace))) - (when member-binding - (incf count) - (push member-binding members-actual-bindings))) - (multiple-value-bind (member-binding bound) - (bind-type member-type sub-binding member - xml-schema-definition namespace) - (when bound - (incf count) - (push `(,(intern member-name (s-xml:get-package namespace)) - , at member-binding) - members-actual-bindings))))) - (if (zerop count) - (unless (is-optional-p member) - (error "Required member ~a not bound" member-name)))) - (let ((sub-bindings (or (get-name-binding member-type bindings) - bindings))) - (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (bind-primitive member member-type - bindings namespace))) - (when member-binding - (push member-binding members-actual-bindings))) - (multiple-value-bind (member-binding bound) - (bind-type member-type sub-bindings member - xml-schema-definition namespace) - (if bound - (push `(,(intern member-name (s-xml:get-package namespace)) - , at member-binding) - members-actual-bindings) - (unless (is-optional-p member) - (error "Required member ~a not bound" member-name))))))))) - `(,(intern (get-name element) (s-xml:get-package namespace)) - ,@(nreverse members-actual-bindings)))) - (t (error "Cannot bind element ~s of type ~s" element element-type))))) - -(defun lxml-primitive-value (name type lxml namespace) - (let ((tag-name (intern name (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag lxml) tag-name) - (values (xsd-primitive->lisp (first (lxml-get-children lxml)) (intern-xsd-type-name type)) t) - (values nil nil)))) - -(defun resolve-primitive (element type-name lxml namespace) - (multiple-value-bind (value present) - (lxml-primitive-value (get-name element) type-name lxml namespace) - (if present - (values value t) - (if (is-optional-p element) - (values nil nil) - (error "Expected a <~a> element" (get-name element)))))) - -(defun resolve-type (type-name lxml super-element xml-schema-definition namespace) - (let* ((type-element (get-element-named xml-schema-definition type-name)) - (type (get-element-type xml-schema-definition type-element))) - (if (typep type 'xsd-complex-type) - (let ((members (get-members type)) - (resolved-members '())) - (loop :for member :in members :do - (let* ((member-name (get-name member)) - (member-type (get-type member)) - (sub-tag-name (intern member-name (s-xml:get-package namespace)))) - (if (is-plural-p member) - (let ((count 0)) - (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (resolve-primitive member member-type item-lxml namespace) - (when required - (incf count) - (push (list member-name member-value) resolved-members))) - (multiple-value-bind (member-value required) - (resolve-type member-type item-lxml member - xml-schema-definition namespace) - (when required - (incf count) - (push (list member-name member-value) resolved-members))))) - (if (zerop count) - (unless (or (is-optional-p member) (get-nillable member)) - (error "Required element <~a> not found" member-name)))) - (let ((member-lxml (lxml-find-tag sub-tag-name lxml))) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (resolve-primitive member member-type member-lxml namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members))) - (multiple-value-bind (member-value required) - (resolve-type member-type member-lxml member - xml-schema-definition namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members)))))))) - (values (nreverse resolved-members) t)) - (if (xsd-primitive-type-name-p type) - (lxml-primitive-value (get-name super-element) type lxml namespace) - (error "unexpected 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) - (resolve-primitive element element-type lxml namespace)) - ((typep element-type 'xsd-complex-type) - (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag lxml) tag-name) - (let ((sub-lxml (lxml-get-children lxml)) - (members (get-members element-type)) - (resolved-members '())) - (loop :for member :in members :do - (let* ((member-name (get-name member)) - (member-type (get-type member)) - (sub-tag-name (intern member-name (s-xml:get-package namespace)))) - (if (is-plural-p member) - (let ((count 0)) - (loop :for item-lxml :in sub-lxml :do - (if (eql (lxml-get-tag item-lxml) sub-tag-name) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (resolve-primitive member member-type item-lxml namespace) - (when required - (incf count) - (push (list member-name member-value) resolved-members))) - (multiple-value-bind (member-value required) - (resolve-type member-type item-lxml member - xml-schema-definition namespace) - (when required - (incf count) - (push (list member-name member-value) resolved-members)))) - (error "Expected a <~a> element" sub-tag-name))) - (if (zerop count) - (unless (or (is-optional-p member) (get-nillable member)) - (error "Required element <~a> not found" member-name)))) - (let ((member-lxml (lxml-find-tag sub-tag-name sub-lxml))) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (resolve-primitive member member-type member-lxml namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members))) - (multiple-value-bind (member-value required) - (resolve-type member-type member-lxml member - xml-schema-definition namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members)))))))) - (values (list (get-name element) (nreverse resolved-members)) t)) - (if (is-optional-p element) - (values nil nil) - (error "Expected a <~a> element" tag-name))))) - (t (error "Cannot resolve element ~s of type ~s" element element-type))))) - ;;; Describing XSD (with pre-rendering of XML) (defun indent (n &optional (stream *standard-output*)) @@ -464,7 +253,7 @@ (let* ((type-element (get-element-named xml-schema-definition type-name)) (type (get-element-type xml-schema-definition type-element))) (if (typep type 'xsd-complex-type) - (let ((members (get-members type))) + (let ((members (get-members type xml-schema-definition))) (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) @@ -488,7 +277,7 @@ (let* ((type-element (get-element-named xml-schema-definition type-name)) (type (get-element-type xml-schema-definition type-element))) (if (typep type 'xsd-complex-type) - (let ((members (get-members type))) + (let ((members (get-members type xml-schema-definition))) (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) @@ -520,7 +309,7 @@ (indent level stream) (format stream " <~a>~a~a~%" element-name element-type element-name (multiplicity-suffix element))) - (let ((members (get-members element-type))) + (let ((members (get-members element-type xml-schema-definition))) (indent level stream) (format stream "Element ~s [~a]~@[ nillable~]~%" element-name (describe-multiplicity element) (get-nillable element)) @@ -563,7 +352,147 @@ :level 1 :stream stream))) (values)) -;;; Primitive Types/Values (types are keywords) +;;; Template Generation (converting the XSD model to something simpler ;-) + +;; an XSD element template looks like this: +;; ELT = ( "element-name" [ :primitive | ELT* ] ) +;; where is 1, ?, + or * and :primitive is a XSD primitive type keyword +;; all element types are resolved into primitives or sequences of sub elements + +(defun get-xsd-template-multiplicity (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)) (if (get-nillable xml-schema-element) '? 1)) + ((and (eql min-occurs 1) (eql max-occurs :unbounded)) (if (get-nillable xml-schema-element) '* '+)) + ((and (zerop min-occurs) (eql max-occurs :unbounded)) '*) + (t :complex)))) + +(defun generate-xsd-template (xml-schema-element xml-schema-definition) + (when (stringp xml-schema-element) + (setf xml-schema-element (or (get-element-named xml-schema-definition xml-schema-element) + (error "Cannot find element named ~s" xml-schema-element)))) + (let ((multiplicity (get-xsd-template-multiplicity xml-schema-element)) + (type (get-element-type xml-schema-definition xml-schema-element)) + (element-name (get-name xml-schema-element))) + (unless (xsd-primitive-type-name-p type) + ;; make sure simple types are resolved to their base primitive type + (setf type (get-element-type xml-schema-definition type))) + (if (xsd-primitive-type-name-p type) + (let ((primitive-type-name (intern-xsd-type-name type))) + `(,multiplicity ,element-name ,primitive-type-name)) + (let ((members (loop :for member :in (get-members type xml-schema-definition) + :collect (generate-xsd-template member xml-schema-definition)))) + `(,multiplicity ,element-name , at members))))) + +(defun generate-xsd-templates (xml-schema-definition) + (loop :for element :in (get-elements xml-schema-definition) + :when (typep element 'xml-schema-element) + :collect (generate-xsd-template element xml-schema-definition))) + +;;; Binding Templates (combining a template with an s-expr to generate an lxml list of tags) + +(defun get-name-binding (name bindings) + (let ((name-binding (member (actual-name name) bindings :test #'equal))) + (if name-binding + (values (second name-binding) t) + (values nil nil)))) + +(defun bind-xsd-template-primitive (tag primitive-type value) + (let ((primitive-value (lisp->xsd-primitive value primitive-type))) + `(,tag ,primitive-value))) + +(defun bind-xsd-template-members (tag members bindings namespace) + (let ((bound-members '())) + (loop :for member :in members :do + (let ((member-binding (bind-xsd-template member bindings namespace))) + (when member-binding + (push member-binding bound-members)))) + `(,tag ,@(reduce #'append (nreverse bound-members))))) + +(defun bind-xsd-template (template bindings namespace) + (destructuring-bind (multiplicity element-name &rest contents) + template + (let ((tag (intern element-name (s-xml:get-package namespace)))) + (multiple-value-bind (value boundp) + (get-name-binding element-name bindings) + (cond ((null contents) `(,tag)) + ((symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) (if boundp + `(,(bind-xsd-template-primitive tag primitive-type value)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if (and boundp value) + (loop :for elt-value :in value + :collect (bind-xsd-template-primitive tag primitive-type elt-value)) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))) + (t + (case multiplicity + ((1 ?) (if boundp + `(,(bind-xsd-template-members tag contents value namespace)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if (and boundp value) + (loop :for elt-value :in value + :collect (bind-xsd-template-members tag contents elt-value namespace)) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))))))) + +(defun bind-element (element bindings xml-schema-definition namespace) + (let ((template (generate-xsd-template element xml-schema-definition))) + (reduce #'append (bind-xsd-template template bindings namespace)))) + +;;; Resolving Templates (combining a template with an lxml list to generate an s-expr) + +(defun resolve-xsd-template-primitive (element-name primitive-type string) + (let ((value (xsd-primitive->lisp string primitive-type))) + `(,element-name ,value))) + +(defun resolve-xsd-template-members (members lxml namespace) + (let ((resolved-members '())) + (loop :for member :in members :do + (let ((member-binding (resolve-xsd-template member lxml namespace))) + (when member-binding + (push member-binding resolved-members)))) + (reduce #'append (nreverse resolved-members)))) + +(defun resolve-xsd-template (template lxml namespace) + (destructuring-bind (multiplicity element-name &rest contents) + template + (let* ((tag (intern element-name (s-xml:get-package namespace))) + (children (lxml-find-tags tag lxml))) + (if (symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) (if children + (resolve-xsd-template-primitive element-name primitive-type (second (first children))) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + (loop :for child :in children + :collect (resolve-xsd-template-primitive element-name primitive-type (second child))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name)))))) + (case multiplicity + ((1 ?) (if children + `(,element-name ,@(resolve-xsd-template-members contents (first children) namespace)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + `(,element-name + ,@(loop :for child :in children + :collect (resolve-xsd-template-members contents child namespace))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))))) + +(defun resolve-element (element lxml xml-schema-definition namespace) + (let ((template (generate-xsd-template element xml-schema-definition))) + (resolve-xsd-template template (list lxml) namespace))) + +;;; Primitive Types/Values (types are identified :keywords) (defconstant +known-primitive-type-names+ '("string" From scaekenberghe at common-lisp.net Fri Sep 30 19:21:44 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 21:21:44 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050930192144.5E8B1880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv7292/src Modified Files: xsd.lisp Log Message: fixed repeating submember representation in sexpr in resolve-xsd-template and friends Date: Fri Sep 30 21:21:43 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.19 cl-soap/src/xsd.lisp:1.20 --- cl-soap/src/xsd.lisp:1.19 Fri Sep 30 19:12:17 2005 +++ cl-soap/src/xsd.lisp Fri Sep 30 21:21:43 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.20 2005/09/30 19:21:43 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -478,13 +478,13 @@ (error "Required repeating element ~s not bound correctly" element-name)))))) (case multiplicity ((1 ?) (if children - `(,element-name ,@(resolve-xsd-template-members contents (first children) namespace)) + `(,element-name ,(resolve-xsd-template-members contents (first children) namespace)) (when (eql multiplicity 1) (error "Required element ~s not bound" element-name)))) ((+ *) (if children `(,element-name - ,@(loop :for child :in children - :collect (resolve-xsd-template-members contents child namespace))) + ,(loop :for child :in children + :collect (resolve-xsd-template-members contents child namespace))) (when (eql multiplicity +) (error "Required repeating element ~s not bound correctly" element-name))))))))) From scaekenberghe at common-lisp.net Fri Sep 30 19:56:02 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 21:56:02 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp Message-ID: <20050930195602.25894880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9321/src Modified Files: lxml.lisp Log Message: added lxml-get-content as proper way to access lxml content (1st child) Date: Fri Sep 30 21:56:01 2005 Author: scaekenberghe Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.7 cl-soap/src/lxml.lisp:1.8 --- cl-soap/src/lxml.lisp:1.7 Sun Sep 25 14:44:18 2005 +++ cl-soap/src/lxml.lisp Fri Sep 30 21:56:00 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.7 2005/09/25 12:44:18 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.8 2005/09/30 19:56:00 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -34,6 +34,10 @@ (cond ((or (symbolp lxml) (stringp lxml)) '()) (t (rest lxml)))) + +(defun lxml-get-contents (lxml) + "Return the contents (first child) of the lxml XML DOM" + (first (lxml-get-children lxml))) (defun lxml-find-tag (tag lxml) "Find a specific tag in a lxml XML DOM list" From scaekenberghe at common-lisp.net Fri Sep 30 19:56:50 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 21:56:50 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/soap.lisp Message-ID: <20050930195650.BF7A2880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9341/src Modified Files: soap.lisp Log Message: better fault parsing Date: Fri Sep 30 21:56:50 2005 Author: scaekenberghe Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.7 cl-soap/src/soap.lisp:1.8 --- cl-soap/src/soap.lisp:1.7 Mon Sep 26 13:15:32 2005 +++ cl-soap/src/soap.lisp Fri Sep 30 21:56:49 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.7 2005/09/26 11:15:32 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.8 2005/09/30 19:56:49 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -35,10 +35,10 @@ (:documentation "Thrown by CL-SOAP when a standard SOAP Fault is read")) (defun lxml->standard-soap-fault (xml) - (let ((code (second (lxml-find-tag :|faultcode| (rest xml)))) - (string (second (lxml-find-tag :|faultstring| (rest xml)))) - (actor (second (lxml-find-tag :|faultactor| (rest xml)))) - (detail (second (lxml-find-tag :|detail| (rest xml))))) + (let ((code (lxml-get-contents (lxml-find-tag :|faultcode| (rest xml)))) + (string (lxml-get-contents (lxml-find-tag :|faultstring| (rest xml)))) + (actor (lxml-get-contents (lxml-find-tag :|faultactor| (rest xml)))) + (detail (lxml-get-contents (lxml-find-tag :|detail| (rest xml))))) (make-condition 'standard-soap-fault :code code :string string From scaekenberghe at common-lisp.net Fri Sep 30 19:57:20 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 21:57:20 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/test-xsd.lisp Message-ID: <20050930195720.DD9AF880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv9362/test Modified Files: test-xsd.lisp Log Message: removed some obsolete tests Date: Fri Sep 30 21:57:20 2005 Author: scaekenberghe Index: cl-soap/test/test-xsd.lisp diff -u cl-soap/test/test-xsd.lisp:1.2 cl-soap/test/test-xsd.lisp:1.3 --- cl-soap/test/test-xsd.lisp:1.2 Fri Sep 30 19:12:20 2005 +++ cl-soap/test/test-xsd.lisp Fri Sep 30 21:57:20 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-xsd.lisp,v 1.2 2005/09/30 17:12:20 scaekenberghe Exp $ +;;;; $Id: test-xsd.lisp,v 1.3 2005/09/30 19:57:20 scaekenberghe Exp $ ;;;; ;;;; Some (internal) test on the implementatin of the XML Schema Definition ;;;; @@ -113,34 +113,6 @@ *google-adwords-ns*))) (let ((schema (get-xml-schema-definition - (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl"))) - (binding '("id" - 5631435 - "name" - "Campaign #1" - "status" - "Active" - "startDate" - 3335857874 - "endDate" - 3502857599 - "dailyBudget" - 1000000 - "optInSearchNetwork" - T - "optInContentNetwork" - T - "languageTargeting" - (("languages" "en") ("languages" "nl")) - "geoTargeting" - (("countries" "BE") ("countries" "NL"))))) - (pprint (bind-type "Campaign" - binding - nil - schema - *google-adwords-ns*))) - -(let ((schema (get-xml-schema-definition (wsdl-cache-get"https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl"))) (binding `("estimateKeywordList" ("keywordRequests" @@ -153,15 +125,6 @@ binding schema *google-adwords-ns*))) - -(let ((schema (get-xml-schema-definition - (wsdl-cache-get"https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl"))) - (binding '("text" "flowers" "type" "Broad" "maxCpc" 50000))) - (pprint (bind-type "KeywordRequest" - binding - nil - schema - *google-adwords-ns*))) (defun test-1 () (let* ((schema (get-xml-schema-definition From scaekenberghe at common-lisp.net Fri Sep 30 19:58:06 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 21:58:06 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp Message-ID: <20050930195806.30774880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9383/src Modified Files: xsd.lisp Log Message: various bugfixes Date: Fri Sep 30 21:58:05 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.20 cl-soap/src/xsd.lisp:1.21 --- cl-soap/src/xsd.lisp:1.20 Fri Sep 30 21:21:43 2005 +++ cl-soap/src/xsd.lisp Fri Sep 30 21:58:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.20 2005/09/30 19:21:43 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.21 2005/09/30 19:58:05 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -358,6 +358,7 @@ ;; ELT = ( "element-name" [ :primitive | ELT* ] ) ;; where is 1, ?, + or * and :primitive is a XSD primitive type keyword ;; all element types are resolved into primitives or sequences of sub elements +;; elements without contents are also possible (defun get-xsd-template-multiplicity (xml-schema-element) (with-slots (min-occurs max-occurs) @@ -464,29 +465,33 @@ template (let* ((tag (intern element-name (s-xml:get-package namespace))) (children (lxml-find-tags tag lxml))) - (if (symbolp (first contents)) - (let ((primitive-type (first contents))) - (case multiplicity - ((1 ?) (if children - (resolve-xsd-template-primitive element-name primitive-type (second (first children))) - (when (eql multiplicity 1) - (error "Required element ~s not bound" element-name)))) - ((+ *) (if children - (loop :for child :in children - :collect (resolve-xsd-template-primitive element-name primitive-type (second child))) - (when (eql multiplicity +) - (error "Required repeating element ~s not bound correctly" element-name)))))) - (case multiplicity - ((1 ?) (if children - `(,element-name ,(resolve-xsd-template-members contents (first children) namespace)) - (when (eql multiplicity 1) - (error "Required element ~s not bound" element-name)))) - ((+ *) (if children - `(,element-name - ,(loop :for child :in children - :collect (resolve-xsd-template-members contents child namespace))) - (when (eql multiplicity +) - (error "Required repeating element ~s not bound correctly" element-name))))))))) + (cond ((null contents) `(,element-name)) + ((symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) (if children + (resolve-xsd-template-primitive element-name primitive-type + (lxml-get-contents (first children))) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + (loop :for child :in children + :collect (resolve-xsd-template-primitive element-name primitive-type + (lxml-get-contents child))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))) + (t + (case multiplicity + ((1 ?) (if children + `(,element-name ,(resolve-xsd-template-members contents (first children) namespace)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + `(,element-name + ,(loop :for child :in children + :collect (resolve-xsd-template-members contents child namespace))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name)))))))))) (defun resolve-element (element lxml xml-schema-definition namespace) (let ((template (generate-xsd-template element xml-schema-definition))) From scaekenberghe at common-lisp.net Fri Sep 30 19:59:27 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 21:59:27 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/src/development.lisp Message-ID: <20050930195927.5A9AC880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9408/src Removed Files: development.lisp Log Message: moved from src to test Date: Fri Sep 30 21:59:26 2005 Author: scaekenberghe From scaekenberghe at common-lisp.net Fri Sep 30 19:59:28 2005 From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe) Date: Fri, 30 Sep 2005 21:59:28 +0200 (CEST) Subject: [cl-soap-cvs] CVS update: cl-soap/test/development.lisp Message-ID: <20050930195928.293E6880DE@common-lisp.net> Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv9408/test Added Files: development.lisp Log Message: moved from src to test Date: Fri Sep 30 21:59:26 2005 Author: scaekenberghe

Phase 1 (First Delivery Target)

Technical Notes

Organizational Notes

Installation Instructions

Status

Next Phase(s) (Future)

Technical Notes

Status