[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp cl-soap/src/namespaces.lisp cl-soap/src/wsdl.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Fri Sep 9 14:17:39 UTC 2005
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
More information about the Cl-soap-cvs
mailing list