Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv1749/src
Modified Files: http-client.lisp soap.lisp wsdl.lisp xsd.lisp Log Message: added some code to handle non 200 http responses
Date: Wed Oct 5 15:24:38 2005 Author: scaekenberghe
Index: cl-soap/src/http-client.lisp diff -u cl-soap/src/http-client.lisp:1.6 cl-soap/src/http-client.lisp:1.7 --- cl-soap/src/http-client.lisp:1.6 Mon Sep 26 13:08:42 2005 +++ cl-soap/src/http-client.lisp Wed Oct 5 15:24:38 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: http-client.lisp,v 1.6 2005/09/26 11:08:42 scaekenberghe Exp $ +;;;; $Id: http-client.lisp,v 1.7 2005/10/05 13:24:38 scaekenberghe Exp $ ;;;; ;;;; A basic HTTP client, somewhat API compatible with portableaserve's do-http-request ;;;; Copied from another project (basic authorization support removed) @@ -228,7 +228,7 @@ headers proxy state) - "Execute an HTTP request" + "Execute an HTTP request, returns (values body code headers uri kept-alive-p)" (declare (ignore proxy)) (assert (member method '(:get :put :post :delete :head))) (setf uri (puri:parse-uri uri))
Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.9 cl-soap/src/soap.lisp:1.10 --- cl-soap/src/soap.lisp:1.9 Mon Oct 3 11:40:35 2005 +++ cl-soap/src/soap.lisp Wed Oct 5 15:24:38 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.9 2005/10/03 09:40:35 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.10 2005/10/05 13:24:38 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -110,28 +110,30 @@ (when *debug-stream* (setf *last-soap-call-xml* call-soap-envelope) (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: ~a~%" result-xml)) - (setf result-soap-envelope (s-xml:parse-xml-string result-xml)) - (when *debug-stream* - (setf *last-soap-result-xml* result-soap-envelope)) - (if (eql (lxml-get-tag result-soap-envelope) 'soapenv:|Envelope|) - (let ((headers (lxml-find-tag 'soapenv:|Header| (rest result-soap-envelope))) - (body (lxml-find-tag 'soapenv:|Body| (rest result-soap-envelope)))) - ;; simply return header key/value pairs as an alist - (setf headers (mapcar #'(lambda (x) (list (lxml-get-tag x) (lxml-get-contents x))) (rest headers))) - ;; only the first child of the body is returned, unless it is a fault - (if body - (let ((fault (lxml-find-tag 'soapenv:|Fault| (rest body)))) - (if fault - (error (lxml->standard-soap-fault fault)) - (values (second body) headers))) - (error "No body found in SOAP Envelope"))) - (error "No SOAP Envelope found")))) + (multiple-value-bind (result code) + (do-http-request (get-url server-end-point) + :method :POST + :headers `(("SOAPAction" . ,(or soap-action ""))) + :content-type "text/xml" + :content call-xml) + (declare (ignore code)) + (when *debug-stream* + (format *debug-stream* ";; SOAP CALL receiving: ~a~%" result-xml)) + (setf result-soap-envelope (s-xml:parse-xml-string result-xml)) + (when *debug-stream* + (setf *last-soap-result-xml* result-soap-envelope)) + (if (eql (lxml-get-tag result-soap-envelope) 'soapenv:|Envelope|) + (let ((headers (lxml-find-tag 'soapenv:|Header| (rest result-soap-envelope))) + (body (lxml-find-tag 'soapenv:|Body| (rest result-soap-envelope)))) + ;; simply return header key/value pairs as an alist + (setf headers (mapcar #'(lambda (x) (list (lxml-get-tag x) (lxml-get-contents x))) (rest headers))) + ;; only the first child of the body is returned, unless it is a fault + (if body + (let ((fault (lxml-find-tag 'soapenv:|Fault| (rest body)))) + (if fault + (error (lxml->standard-soap-fault fault)) + (values (second body) headers))) + (error "No body found in SOAP Envelope"))) + (error "No SOAP Envelope found")))))
;;;; eof
Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.21 cl-soap/src/wsdl.lisp:1.22 --- cl-soap/src/wsdl.lisp:1.21 Mon Oct 3 11:40:35 2005 +++ cl-soap/src/wsdl.lisp Wed Oct 5 15:24:38 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.21 2005/10/03 09:40:35 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.22 2005/10/05 13:24:38 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -297,9 +297,12 @@ (parse-wsdl in)))
(defun parse-wsdl-url (url) - (let ((buffer (do-http-request url))) - (with-input-from-string (in buffer) - (parse-wsdl in)))) + (multiple-value-bind (buffer code) + (do-http-request url) + (if (eql code 200) + (with-input-from-string (in buffer) + (parse-wsdl in)) + (error "Could not retrieve URL ~s, got a ~s code" url code))))
;; A simple caching mechanism for WSDL's by URL
Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.24 cl-soap/src/xsd.lisp:1.25 --- cl-soap/src/xsd.lisp:1.24 Mon Oct 3 14:24:10 2005 +++ cl-soap/src/xsd.lisp Wed Oct 5 15:24:38 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.24 2005/10/03 12:24:10 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.25 2005/10/05 13:24:38 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -149,9 +149,12 @@ (parse-xsd in)))
(defun parse-xsd-url (url) - (let ((buffer (do-http-request url))) - (with-input-from-string (in buffer) - (parse-xsd in)))) + (multiple-value-bind (buffer code) + (do-http-request url) + (if (eql code 200) + (with-input-from-string (in buffer) + (parse-xsd in)) + (error "Could not retrieve URL ~s, got a ~s code" url code))))
;;; Interpreting the XSD model