[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Tue Sep 13 19:23:50 UTC 2005
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
More information about the Cl-soap-cvs
mailing list