Add support for client side HTTPS via OpenSSL (connection pooling wor…

…king)
vii · Oct 24, 2010 · b177189 · b177189
1 parent 44dcc24
commit b177189
Show file tree

Hide file tree

Showing 6 changed files with 47 additions and 40 deletions.
diff --git a/src/http/request.lisp b/src/http/request.lisp
@@ -95,8 +95,8 @@
   (con-clear-failure-callbacks con)
   (hangup con))
 
-(defun get-http-request-con (address port)
-  (let ((con (pop (gethash (list address port) *connection-cache*))))
+(defun get-http-request-con (ssl address port)
+  (let ((con (pop (gethash (list ssl address port) *connection-cache*))))
     (cond (con
 	   (con-clear-failure-callbacks con)
 	   (reset-timeout con)
@@ -105,11 +105,14 @@
 		  con)
 		 (t
 		  (hangup con)
-		  (get-http-request-con address port))))
+		  (get-http-request-con ssl address port))))
 	  (t
-	   (make-con-connect :address address :port port)))))
+	   (let ((con (make-con-connect :address address :port port)))
+	     (when ssl
+	       (convert-con-to-ssl con))
+	     con)))))
 
-(defun launch-http-request (&key (port 80) address body 
+(defun launch-http-request (&key ssl (port (if ssl 443 80)) address body 
 			    (path (force-byte-vector "/")) 
 			    extra-header-lines
 			    hostname
@@ -121,7 +124,7 @@
     (setf address (lookup-hostname hostname)))
   (unless address
     (error "Please specify an address"))
-  (let ((con (get-http-request-con address port)) succeeded)
+  (let ((con (get-http-request-con ssl address port)) succeeded)
     (when failure
       (con-add-failure-callback con (lambda(e) (unless succeeded (funcall failure e)))))
     (when timeout
@@ -145,4 +148,4 @@
 		 +newline+
 		 body)
 	       (lambda(&rest args)(setf succeeded t) (apply done args))
-	       :connection-cache (list address port))))
+	       :connection-cache (list ssl address port))))
diff --git a/src/io/epoll.lisp b/src/io/epoll.lisp
@@ -43,8 +43,8 @@
 
 (my-defun epoll handle-postponed-registrations ()
     (assert (not (my postpone-registration)))
-    (adolist (my postponed-registrations)
-      (my 'mux-add it))
+    (loop for (fd . con) in (my postponed-registrations) do
+      (my 'mux-add fd con))
     (setf (my postponed-registrations) nil))
 
 (my-defun epoll wait (timeout)
@@ -77,17 +77,16 @@
 
 (defvar *epoll* (make-epoll))
 
-(defun register-fd (events con)
+(defun register-fd (fd events con)
   (with-shorthand-accessor (my epoll *epoll*)
-    (let ((fd (con-socket con)))
-      (cond ((my 'mux-find-fd fd) 
-	     (debug-assert (eq con (my 'mux-find-fd fd)) (*epoll* con fd)) 
-	     (my ctl +EPOLL_CTL_MOD+ fd events))
-	    (t
-	     (if (my postpone-registration)
-		 (push con (my postponed-registrations))
-		 (my 'mux-add con))
-	     (my ctl +EPOLL_CTL_ADD+ fd events))))))
+    (cond ((my 'mux-find-fd fd) 
+	   (debug-assert (eq con (my 'mux-find-fd fd)) (*epoll* con fd)) 
+	   (my ctl +EPOLL_CTL_MOD+ fd events))
+	  (t
+	   (if (my postpone-registration)
+	       (push (cons fd con) (my postponed-registrations))
+	       (my 'mux-add fd con))
+	   (my ctl +EPOLL_CTL_ADD+ fd events)))))
 
 (defun deregister-fd (fd)
   (declare (optimize speed))
@@ -97,8 +96,6 @@
 (defun-speedy events-pending-p ()
   (not (mux-empty *epoll*)))
 
-
-
 (defun wait-for-next-event (&optional timeout)
   (with-shorthand-accessor (my epoll *epoll*)
     (my wait timeout)))

diff --git a/src/io/mux.lisp b/src/io/mux.lisp
@@ -18,25 +18,24 @@
     (when (> (length (my fd-to-con)) fd)
       (aref (my fd-to-con) fd))))
 
-(my-defun mux add (con)
-  (let ((fd (con-socket con)))
-    (declare (type (or null fixnum) fd))
-    (when fd
-      (debug-assert (not (my find-fd fd)) (me con fd))
-      (when (>= fd (length (my fd-to-con)))
-	(let ((new (make-mux-array  
-		    (loop for length = (* 2 (length (my fd-to-con))) then (* 2 length)
-			  thereis (when (> length fd) length)))))
-	  (replace new (my fd-to-con))
-	  (setf (my fd-to-con) new))
-	(debug-assert (> (length (my fd-to-con)) fd) (me fd)))
-      (setf (aref (my fd-to-con) fd) con))))
+(my-defun mux add (fd con)
+  (declare (type (or null fixnum) fd))
+  (when fd
+    (debug-assert (not (my find-fd fd)) (me con fd))
+    (when (>= fd (length (my fd-to-con)))
+      (let ((new (make-mux-array  
+		  (loop for length = (* 2 (length (my fd-to-con))) then (* 2 length)
+			thereis (when (> length fd) length)))))
+	(replace new (my fd-to-con))
+	(setf (my fd-to-con) new))
+      (debug-assert (> (length (my fd-to-con)) fd) (me fd)))
+    (setf (aref (my fd-to-con) fd) con)))
 
 (my-defun mux del (fd)
   (my-declare-fast-inline)
   (declare (fixnum fd))
   (when (my find-fd fd)
-    (debug-assert (= (con-socket (aref (my fd-to-con) fd)) fd) (me fd))
+    ;(debug-assert (= (con-socket (aref (my fd-to-con) fd)) fd) (me fd)) ;; not vaild when ssl involved
     (setf (aref (my fd-to-con) fd) nil)))
 
 (my-defun mux close-all ()

diff --git a/src/io/posix-socket.lisp b/src/io/posix-socket.lisp
@@ -82,7 +82,7 @@
 
 (defmethod socket-register ((fd integer) events con)
   (debug-assert (eql fd (con-socket con)) (fd con))
-  (register-fd events con))
+  (register-fd fd events con))
 
 (defmethod socket-supports-writev ( (fd integer))
   (declare (ignore fd))

diff --git a/src/packages.lisp b/src/packages.lisp
@@ -212,6 +212,8 @@
    #:con-default-timeout-function
    #:con-timeout
    #:con-hangup-hook
+
+   #:convert-con-to-ssl
 
    #:+newline+
    #:+SOCK_DGRAM+

diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -5,9 +5,10 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (asdf:operate 'asdf:load-op 'cl-fad))
 
-(loop for addon in (remove-if-not 'cl-fad:directory-pathname-p (cl-fad:list-directory "addons"))
-      do
-      (pushnew addon asdf:*central-registry* :test #'equal))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (loop for addon in (remove-if-not 'cl-fad:directory-pathname-p (cl-fad:list-directory "addons"))
+	do
+	(pushnew addon asdf:*central-registry* :test #'equal)))
 
 #+tpd2-debug
 (progn
@@ -52,7 +53,12 @@
 							    (:file "epoll" :depends-on ("syscalls" "mux"))
 							    (:file "syscalls")
 							    (:file "protocol" :depends-on ("socket" "con"))
-							    (:file "repeater" :depends-on ("con" "protocol"))))
+							    (:file "repeater" :depends-on ("con" "protocol"))
+							    (:file "openssl")
+							    (:file "ssl" :depends-on ("con" "openssl"))
+							    )
+
+					       )
 
 				     (:module :http
 					      :depends-on (:lib :io)