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

Modified Files: lxml.lisp namespaces.lisp wsdl.lisp Log Message: first code to parse generic (non-soap-binding) wsdl into a lisp model

Date: Fri Sep 9 16:17:38 2005 Author: scaekenberghe

Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.1 cl-soap/src/lxml.lisp:1.2 --- cl-soap/src/lxml.lisp:1.1 Mon Sep 5 10:35:55 2005 +++ cl-soap/src/lxml.lisp Fri Sep 9 16:17:37 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.1 2005/09/05 08:35:55 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.2 2005/09/09 14:17:37 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -17,6 +17,11 @@ (if (symbolp (first lxml)) (first lxml) (first (first lxml)))) + +(defun lxml-get-attributes (lxml) + (if (symbolp (first lxml)) + '() + (rest (first lxml))))

(defun lxml-find-tag (tag lxml) (find tag lxml :key #'lxml-get-tag))

Index: cl-soap/src/namespaces.lisp diff -u cl-soap/src/namespaces.lisp:1.2 cl-soap/src/namespaces.lisp:1.3 --- cl-soap/src/namespaces.lisp:1.2 Thu Sep 8 17:39:42 2005 +++ cl-soap/src/namespaces.lisp Fri Sep 9 16:17:37 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: namespaces.lisp,v 1.2 2005/09/08 15:39:42 scaekenberghe Exp $ +;;;; $Id: namespaces.lisp,v 1.3 2005/09/09 14:17:37 scaekenberghe Exp $ ;;;; ;;;; Definition of some standard XML namespaces commonly needed for SOAP ;;;; @@ -60,7 +60,9 @@

(defpackage :wsdl (:nicknames "wsdl") - (:export) + (:export + "definitions" "documentation" + "portType" "message" "operation" "port" "service" "binding" "part" "input" "output" "fault") (:documentation "Package for symbols in the WSDL XML Namespace"))

(defparameter *wsdl-ns* (s-xml:register-namespace +wsdl-ns-uri+ "wsdl" :wsdl))

Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.1 cl-soap/src/wsdl.lisp:1.2 --- cl-soap/src/wsdl.lisp:1.1 Mon Sep 5 10:35:55 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 9 16:17:37 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.1 2005/09/05 08:35:55 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.2 2005/09/09 14:17:37 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol ;;;; @@ -16,33 +16,41 @@ ;;; Generic Soap Model

(defclass abstract-wsdl-definition () - ((name) - (documentation))) + ((name :accessor get-name :initarg :name :initform nil) + (documentation :accessor get-documentation :initarg :documentation :initform nil))) + +(defmethod print-object ((object abstract-wsdl-definition) out) + (print-unreadable-object (object out :type t :identity t) + (prin1 (or (get-name object) "anonymous") out)))

(defclass wsdl-document-definitions (abstract-wsdl-definition) - ((target-namespace) - (types) - (messages) - (port-types) - (bindings) - (services))) + ((target-namespace :accessor get-target-namespace :initarg :target-namespace :initform nil) + (types :accessor get-types :initarg :types :initform nil) + (messages :accessor get-messages :initarg :messages :initform nil) + (port-types :accessor get-port-types :initarg :port-types :initform nil) + (bindings :accessor get-bindings :initarg :bindings :initform nil) + (services :accessor get-services :initarg :bindings :initform nil)))

(defclass wsdl-service (abstract-wsdl-definition) - ((ports))) + ((ports :accessor get-ports :initarg :ports :initform nil)))

(defclass wsdl-port (abstract-wsdl-definition) - ((binding) + ((binding :accessor get-binding :initarg :binding :initform nil) (network-address)))

(defclass wsdl-binding (abstract-wsdl-definition) - ((type) - (operations))) + ((type :accessor get-type :initarg :type :initform nil) + (operations :accessor get-operations :initarg :operations :initform nil)))

(defclass wsdl-port-type (abstract-wsdl-definition) - ((operations))) + ((operations :accessor get-operations :initarg :operations :initform nil)))

(defclass wsdl-operation-element () - ((message))) + ((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) + (prin1 (get-message object) out)))

(defclass wsdl-input (wsdl-operation-element) ()) @@ -54,15 +62,19 @@ ())

(defclass wsdl-operation (abstract-wsdl-definition) - ((elements))) + ((elements :accessor get-elements :initarg :elements :initform nil)))

(defclass wsdl-part () - ((name) - (element) - (type))) + ((name :accessor get-name :initarg :name :initform nil) + (element :accessor get-element :initarg :element :initform nil) + (type :accessor get-type :initarg :type :initform nil))) + +(defmethod print-object ((object wsdl-part) out) + (print-unreadable-object (object out :type t :identity t) + (prin1 (or (get-name object) "anonymous") out)))

(defclass wsdl-message (abstract-wsdl-definition) - ((parts))) + ((parts :accessor get-parts :initarg :parts :initform nil)))

(defclass wsdl-type (abstract-wsdl-definition) ((data-type-definitions))) @@ -101,5 +113,117 @@

(defclass wsdl-soap-header-fault (wsdl-soap-header) ()) + +;; Parsing + +(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-operation)) + +(defun lxml->port-type (lxml) + (let* ((attributes (lxml-get-attributes lxml)) + (name (getf attributes :|name|)) + (wsdl-port-type (make-instance 'wsdl-port-type :name name))) + (loop :for element :in (rest lxml) + :do (case (lxml-get-tag element) + (wsdl:|operation| (push (lxml->operation element) + (get-operations wsdl-port-type))))) + wsdl-port-type)) + +(defun lxml->part (lxml) + (let* ((attributes (lxml-get-attributes lxml)) + (name (getf attributes :|name|)) + (element (getf attributes :|element|)) + (type (getf attributes :|type|)) + (wsdl-part (make-instance 'wsdl-part + :name name + :element element + :type type))) + wsdl-part)) + +(defun lxml->message (lxml) + (let* ((attributes (lxml-get-attributes lxml)) + (name (getf attributes :|name|)) + (wsdl-message (make-instance 'wsdl-message :name name))) + (loop :for element :in (rest lxml) + :do (case (lxml-get-tag element) + (wsdl:|part| (push (lxml->part element) + (get-parts wsdl-message))))) + wsdl-message)) + +(defun lxml->binding (lxml) + (let* ((attributes (lxml-get-attributes lxml)) + (name (getf attributes :|name|)) + (type (getf attributes :|type|)) + (wsdl-binding (make-instance 'wsdl-binding :name name :type type))) + (loop :for element :in (rest lxml) + :do (case (lxml-get-tag element) + (wsdl:|operation| (push (lxml->operation element) + (get-operations wsdl-binding))))) + wsdl-binding)) + +(defun lxml->port (lxml) + (let* ((attributes (lxml-get-attributes lxml)) + (name (getf attributes :|name|)) + (binding (getf attributes :|binding|)) + (wsdl-port (make-instance 'wsdl-port :name name :binding binding))) + wsdl-port)) + +(defun lxml->service (lxml) + (let* ((attributes (lxml-get-attributes lxml)) + (name (getf attributes :|name|)) + (wsdl-service (make-instance 'wsdl-service :name name))) + (loop :for element :in (rest lxml) + :do (case (lxml-get-tag element) + (wsdl:|port| (push (lxml->port element) + (get-ports wsdl-service))))) + wsdl-service)) + +(defun parse-wsdl (in) + (let ((lxml (s-xml:parse-xml in))) + (if (eql (lxml-get-tag lxml) 'wsdl:|definitions|) + (let* ((attributes (lxml-get-attributes lxml)) + (name (getf attributes :|name|)) + (target-namespace (getf attributes :|targetNamespace|)) + (wsdl-document-definitions (make-instance 'wsdl-document-definitions + :name name + :target-namespace target-namespace))) + (loop :for element :in (rest lxml) + :do (case (lxml-get-tag element) + (wsdl:|documentation| (setf (get-documentation wsdl-document-definitions) + (rest element))) + (wsdl:|types|) + (wsdl:|message| (push (lxml->message element) + (get-messages wsdl-document-definitions))) + (wsdl:|portType| (push (lxml->port-type element) + (get-port-types wsdl-document-definitions))) + (wsdl:|binding| (push (lxml->binding element) + (get-bindings wsdl-document-definitions))) + (wsdl:|service| (push (lxml->service element) + (get-services wsdl-document-definitions))))) + wsdl-document-definitions) + (error "Expected a WSDL <definitions> 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