[cl-soap-cvs] CVS update: cl-soap/src/http-client.lisp cl-soap/src/soap.lisp

[Sven Van Caekenberghe]

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| , at header-attributes) , at header-lxml)) 
+      `((soapenv:|Header| , at header-lxml)))))
+
+(defun soap-body (body-lxml &optional body-attributes)
+  (if body-attributes
+      `((soapenv:|Body| , at 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+)
-    , at header
-    (soapenv:|Body| ,body)))
+     :|xmlns:xsi| ,+xsi-ns-uri+
+     , at 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