[cl-soap-cvs] CVS update: cl-soap/src/http-client.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Thu Sep 15 13:30:45 UTC 2005
Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv23294/src
Modified Files:
http-client.lisp
Log Message:
added https support for lispworks
Date: Thu Sep 15 15:30:44 2005
Author: scaekenberghe
Index: cl-soap/src/http-client.lisp
diff -u cl-soap/src/http-client.lisp:1.4 cl-soap/src/http-client.lisp:1.5
--- cl-soap/src/http-client.lisp:1.4 Wed Sep 14 09:30:02 2005
+++ cl-soap/src/http-client.lisp Thu Sep 15 15:30:44 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: http-client.lisp,v 1.4 2005/09/14 07:30:02 scaekenberghe Exp $
+;;;; $Id: http-client.lisp,v 1.5 2005/09/15 13:30:44 scaekenberghe Exp $
;;;;
;;;; A basic HTTP client, somewhat API compatible with portableaserve's do-http-request
;;;; Copied from another project (basic authorization support removed)
@@ -21,10 +21,14 @@
(defclass http-client-state ()
((data :initform nil)))
-(defvar *default-http-client-state* (make-instance 'http-client-state))
+(defun make-http-client-state ()
+ "Make a new HTTP client state object to hold open (keepalive) connections"
+ (make-instance 'http-client-state))
+
+(defvar *default-http-client-state* (make-http-client-state))
(defclass http-server-state ()
- ((host-port :accessor get-host-port :initarg :host-port)
+ ((scheme-host-port :accessor get-scheme-host-port :initarg :scheme-host-port)
(socket :accessor get-socket :initarg :socket :initform nil)))
;; low level output
@@ -99,16 +103,17 @@
;; connection / server state management
-(defmethod get-http-server-state ((http-client-state http-client-state) host-port)
+(defmethod get-http-server-state ((http-client-state http-client-state) scheme-host-port)
(with-slots (data)
http-client-state
- (let ((server-state (find host-port data :key #'get-host-port :test #'string-equal)))
+ (let ((server-state (find scheme-host-port data :key #'get-scheme-host-port :test #'string-equal)))
(unless server-state
- (push (setf server-state (make-instance 'http-server-state :host-port host-port))
+ (push (setf server-state (make-instance 'http-server-state :scheme-host-port scheme-host-port))
data))
server-state)))
(defmethod close-all-connections ((http-client-state http-client-state) &key abort)
+ "Close all open connections in http-client-state (optionaly aborting them)"
(with-slots (data)
http-client-state
(dolist (http-server-state data)
@@ -116,30 +121,36 @@
(when connection
(ignore-errors (close connection :abort abort)))))))
-(defun open-socket-stream (host port)
- #+lispworks (comm:open-tcp-stream host port)
- #+openmcl (ccl:make-socket :remote-host host :remote-port port)
- #+clisp (socket:socket-connect port host)
- #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port) :input t :output t :buffering :none)
- #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)))
- (sb-bsd-sockets:socket-connect socket
- (car
- (sb-bsd-sockets:host-ent-addresses
- (sb-bsd-sockets:get-host-by-name host)))
- port)
- (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t :buffering :none)))
+(defun open-socket-stream (scheme host port)
+ #+lispworks (ecase scheme
+ (:http (comm:open-tcp-stream host port))
+ (:https (comm:open-tcp-stream host port :ssl-ctx t)))
+ #+openmcl (when (eql scheme :http)
+ (ccl:make-socket :remote-host host :remote-port port))
+ #+clisp (when (eql scheme :http)
+ (socket:socket-connect port host))
+ #+cmu (when (eql scheme :http)
+ (sys:make-fd-stream (ext:connect-to-inet-socket host port) :input t :output t :buffering :none))
+ #+sbcl (when (eql scheme :http)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect socket
+ (car
+ (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name host)))
+ port)
+ (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t :buffering :none))))
-(defun get-open-connection (host port state &key force-new)
+(defun get-open-connection (scheme host port state &key force-new)
(if state
- (let* ((host-port (format nil "~a:~d" host port))
- (server-state (get-http-server-state state host-port))
+ (let* ((scheme-host-port (format nil "~a://~a:~d" scheme host port))
+ (server-state (get-http-server-state state scheme-host-port))
(connection (get-socket server-state)))
(if (and connection (open-stream-p connection) (not force-new))
(values connection :keep-alive)
(progn
(when connection (ignore-errors (close connection)))
- (values (setf (get-socket server-state) (open-socket-stream host port)) :new))))
- (values (open-socket-stream host port) :new)))
+ (values (setf (get-socket server-state) (open-socket-stream scheme host port)) :new))))
+ (values (open-socket-stream scheme host port) :new)))
;; high level HTTP protocol
@@ -167,7 +178,9 @@
content content-type
headers)
"Write an HTTP request, full header and body, to stream"
- (format-http-request-line stream "~a ~a~@[?~a~] HTTP/1.1" method (puri:uri-path uri) (puri:uri-query uri))
+ (format-http-request-line stream
+ "~a ~a~@[?~a~] HTTP/1.1"
+ method (if (puri:uri-path uri) (puri:uri-path uri) "/") (puri:uri-query uri))
(format-http-request-line stream "Host: ~a:~d" (puri:uri-host uri) (puri:uri-port uri))
(format-http-request-line stream "User-Agent: ~a" *http-client-agent*)
(format-http-request-line stream "Accept: ~a" *http-client-accept*)
@@ -206,11 +219,15 @@
(declare (ignore proxy))
(assert (member method '(:get :put :post :delete :head)))
(setf uri (puri:parse-uri uri))
- (let* ((host (puri:uri-host uri))
- (port (or (puri:uri-port uri) (setf (puri:uri-port uri) 80))))
+ (let* ((scheme (puri:uri-scheme uri))
+ (host (puri:uri-host uri))
+ (port (or (puri:uri-port uri)
+ (setf (puri:uri-port uri) (ecase scheme
+ (:http 80)
+ (:https 443))))))
(multiple-value-bind (connection keep-alive)
;; state could hold an open (kept alive) connection to host:port
- (get-open-connection host port state)
+ (get-open-connection scheme host port state)
(flet ((execute-request-response ()
(values-list `(,@(multiple-value-list
(do-one-request-response connection uri method
@@ -225,7 +242,7 @@
((or stream-error #+lispworks comm:socket-error) ()
(when keep-alive
(setf keep-alive :new
- connection (get-open-connection host port state :force-new t))
+ connection (get-open-connection scheme host port state :force-new t))
(execute-request-response))))
(unless state (close connection)))))))
More information about the Cl-soap-cvs
mailing list