Skip to content
Browse files

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

…king)
  • Loading branch information...
1 parent 44dcc24 commit b177189abbac5178a805b3e174aa605ea5727d59 @vii committed Oct 24, 2010
Showing with 47 additions and 40 deletions.
  1. +10 −7 src/http/request.lisp
  2. +11 −14 src/io/epoll.lisp
  3. +13 −14 src/io/mux.lisp
  4. +1 −1 src/io/posix-socket.lisp
  5. +2 −0 src/packages.lisp
  6. +10 −4 teepeedee2.asd
View
17 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))))
View
25 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)))
View
27 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 ()
View
2 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))
View
2 src/packages.lisp
@@ -212,6 +212,8 @@
#:con-default-timeout-function
#:con-timeout
#:con-hangup-hook
+
+ #:convert-con-to-ssl
#:+newline+
#:+SOCK_DGRAM+
View
14 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)

0 comments on commit b177189

Please sign in to comment.
Something went wrong with that request. Please try again.