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