Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv21139/src
Modified Files: http-client.lisp soap.lisp Log Message: some changed to allow more (optional) customization options to envelope/header/body attributes and some changes to the header itself
Date: Fri Sep 9 13:21:17 2005 Author: scaekenberghe
Index: cl-soap/src/http-client.lisp diff -u cl-soap/src/http-client.lisp:1.2 cl-soap/src/http-client.lisp:1.3 --- cl-soap/src/http-client.lisp:1.2 Thu Sep 8 17:39:42 2005 +++ cl-soap/src/http-client.lisp Fri Sep 9 13:21:16 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: http-client.lisp,v 1.2 2005/09/08 15:39:42 scaekenberghe Exp $ +;;;; $Id: http-client.lisp,v 1.3 2005/09/09 11:21:16 scaekenberghe Exp $ ;;;; ;;;; A basic HTTP client, somewhat API compatible with portableaserve's do-http-request ;;;; Copied from another project (basic authorization support removed) @@ -13,6 +13,8 @@ ;;;;
(in-package :cl-soap) + +#+lispworks (require "comm")
;; data structures for state management
Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.2 cl-soap/src/soap.lisp:1.3 --- cl-soap/src/soap.lisp:1.2 Thu Sep 8 17:39:42 2005 +++ cl-soap/src/soap.lisp Fri Sep 9 13:21:16 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.2 2005/09/08 15:39:42 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.3 2005/09/09 11:21:16 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -57,33 +57,45 @@
;;; SOAP content generation support
-(defun soap-header (simple-header-alist) - (cons 'soapenv:|Header| simple-header-alist)) +(defun soap-header (header-lxml &optional header-attributes) + (when header-lxml + (if header-attributes + `(((soapenv:|Header| ,@header-attributes) ,@header-lxml)) + `((soapenv:|Header| ,@header-lxml))))) + +(defun soap-body (body-lxml &optional body-attributes) + (if body-attributes + `((soapenv:|Body| ,@body-attributes) ,body-lxml) + `(soapenv:|Body| ,body-lxml)))
-(defun soap-envelope (header body) +(defun soap-envelope (header body &key envelope-attributes header-attributes body-attributes) `((soapenv:|Envelope| :|xmlns:soapenv| ,+soapenv-ns-uri+ :|xmlns:xsd| ,+xsd-ns-uri+ - :|xmlns:xsi| ,+xsi-ns-uri+) - ,@header - (soapenv:|Body| ,body))) + :|xmlns:xsi| ,+xsi-ns-uri+ + ,@envelope-attributes) + ,@(soap-header header header-attributes) + ,(soap-body body body-attributes)))
;;; Call Interface
-(defun soap-call (server-end-point header body &key soap-action) +(defun soap-call (server-end-point header body &key soap-action envelope-attributes header-attributes body-attributes) "Make a SOAP Call to server-end-point using headers and body" - (let* ((call-soap-envelope (soap-envelope header body)) - (call-xml (s-xml:print-xml-string call-soap-envelope)) + (let* ((call-soap-envelope (soap-envelope header body + :envelope-attributes envelope-attributes + :header-attributes header-attributes + :body-attributes body-attributes)) + (call-xml (s-xml:print-xml-string call-soap-envelope :pretty t)) result-xml result-soap-envelope) (when *debug-stream* - (format *debug-stream* ";; SOAP CALL sending: ~s~%" call-xml)) + (format *debug-stream* ";; SOAP CALL sending: ~a~%" call-xml)) (setf result-xml (do-http-request (get-url server-end-point) :method :POST :headers `(("SOAPAction" . ,(or soap-action ""))) :content-type "text/xml" :content call-xml)) (when *debug-stream* - (format *debug-stream* ";; SOAP CALL receiving: ~s~%" result-xml)) + (format *debug-stream* ";; SOAP CALL receiving: ~a~%" result-xml)) (setf result-soap-envelope (s-xml:parse-xml-string result-xml)) (if (eql (lxml-get-tag result-soap-envelope) 'soapenv:|Envelope|) ;; we ignore returned headers for now