[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Mon Sep 19 18:26:57 UTC 2005
Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv27664/src
Modified Files:
wsdl.lisp
Log Message:
restructured wsdl-soap-call in preparation of extentions
Date: Mon Sep 19 20:26:56 2005
Author: scaekenberghe
Index: cl-soap/src/wsdl.lisp
diff -u cl-soap/src/wsdl.lisp:1.8 cl-soap/src/wsdl.lisp:1.9
--- cl-soap/src/wsdl.lisp:1.8 Fri Sep 16 14:54:34 2005
+++ cl-soap/src/wsdl.lisp Mon Sep 19 20:26:55 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: wsdl.lisp,v 1.8 2005/09/16 12:54:34 scaekenberghe Exp $
+;;;; $Id: wsdl.lisp,v 1.9 2005/09/19 18:26:55 scaekenberghe Exp $
;;;;
;;;; The basic WSDL protocol: we parse the generic and soap specific parts
;;;;
@@ -373,6 +373,112 @@
;; Using WSDL to make structured SOAP calls
+(defun bind-input-parts (input-message input)
+ (let ((actual-input-parameters '()))
+ (loop :for part :in (get-parts input-message) :do
+ (let* ((value (second (member (get-name part) input :test #'equal)))
+ (part-type (get-type part)))
+ (if value
+ (push `((,(intern (get-name part) :keyword)
+ xsi::|type| ,(get-type part))
+ ;; basic type conversions ;-)
+ ,(if (xsd-primitive-type-name-p part-type)
+ (lisp->xsd-primitive value (intern-xsd-type-name part-type))
+ (princ-to-string value)))
+ actual-input-parameters)
+ (error "No input binding found for ~a:~a" (get-name input-message) (get-name part)))))
+ (nreverse actual-input-parameters)))
+
+(defun bind-headers (headers)
+ (declare (ignore headers))
+ nil)
+
+(defun bind-output-parts (result output-message output)
+ (declare (ignore output))
+ (let ((result-values '()))
+ (loop :for part :in (get-parts output-message) :do
+ (let* ((part-element (lxml-find-tag (intern (get-name part) :keyword) (rest result)))
+ (part-value (second part-element))
+ (part-type (get-type part))) ;; part-element might have a type attribute as well
+ ;; basic type conversions ;-)
+ (if (xsd-primitive-type-name-p part-type)
+ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type))
+ result-values)
+ (push part-value result-values))))
+ (if (= (length result-values) 1)
+ (first result-values)
+ (nreverse result-values))))
+
+(defun wsdl-soap-rpc-call (soap-end-point
+ soap-action
+ binding-operation
+ input-message
+ output-message
+ soap-input-body
+ soap-output-body
+ input
+ output
+ headers)
+ (let ((input-namespace-uri (get-namespace soap-input-body))
+ (output-namespace-uri (get-namespace soap-output-body)))
+ (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"))
+ (let* ((input-wrapper (intern (get-name binding-operation) :ns1))
+ (result (soap-call soap-end-point
+ (bind-headers headers)
+ `((,input-wrapper
+ soapenv:|encodingStyle| ,+soap-enc-ns-uri+
+ :|xmlns:ns1| ,input-namespace-uri)
+ ,@(bind-input-parts input-message input))
+ :soap-action soap-action))
+ (output-wrapper (intern (get-name output-message) :ns1)))
+ (if (eql (lxml-get-tag result) output-wrapper)
+ (bind-output-parts result output-message output)
+ (error "Expected <~a> element" output-wrapper)))))
+
+(defun wsdl-soap-call-internal (wsdl-document-definitions
+ port
+ operation-name
+ input
+ output
+ headers)
+ (let* ((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/"))
+ (wsdl-soap-rpc-call soap-end-point
+ soap-action
+ binding-operation
+ input-message
+ output-message
+ soap-input-body
+ soap-output-body
+ input
+ output
+ headers)
+ (error "Only standard SOAP RPC style currently supported as binding"))
+ (error "Only standard SOAP HTTP transport currently supported as binding"))))
+
;; 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)
@@ -389,7 +495,6 @@
output
headers)
"Use WSDL to make a SOAP call of operation/port/service using input/output/headers"
- (declare (ignore output headers))
(let* ((wsdl-document-definitions (etypecase wsdl
(wsdl-document-definitions wsdl)
(string (parse-wsdl-url wsdl))
@@ -399,74 +504,12 @@
(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)))
- (part-type (get-type part)))
- (if value
- (push `((,(intern (get-name part) :keyword)
- xsi::|type| ,(get-type part))
- ;; basic type conversions ;-)
- ,(if (xsd-primitive-type-name-p part-type)
- (lisp->xsd-primitive value (intern-xsd-type-name part-type))
- (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)))
- (part-value (second part-element))
- (part-type (get-type part))) ;; part-element might have a type attribute as well
- ;; basic type conversions ;-)
- (if (xsd-primitive-type-name-p part-type)
- (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type))
- result-values)
- (push part-value result-values))))
- (if (= (length result-values) 1)
- (first 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"))))
+ (first (get-ports service)))))
+ (wsdl-soap-call-internal wsdl-document-definitions
+ port
+ operation-name
+ input
+ output
+ headers)))
;;;; eof
More information about the Cl-soap-cvs
mailing list