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