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