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