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)))))))