Permalink
Browse files

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

…king)
  • Loading branch information...
1 parent 3eb1330 commit 44dcc2487253bb9319cbf87b7dc287edcd72294e @vii committed Oct 24, 2010
Showing with 204 additions and 0 deletions.
  1. +99 −0 src/io/openssl.lisp
  2. +105 −0 src/io/ssl.lisp
View
@@ -0,0 +1,99 @@
+(in-package #:tpd2.io)
+
+;; FFI for OpenSSL library
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (cffi:define-foreign-library libssl
+ (:unix "libssl.so")
+ (t (:default "libssl3")))
+
+ (cffi:use-foreign-library libssl)
+
+ #+freebsd
+ (progn
+ (cffi:define-foreign-library libcrypto
+ (:unix (:or "libcrypto.so" "/usr/local/lib/libcrypto.so"))
+ (t (:default "libcrypto")))
+ (cffi:use-foreign-library libcrypto)))
+
+(defconstant +SSL_ERROR_NONE+ 0)
+(defconstant +SSL_ERROR_WANT_READ+ 2)
+(defconstant +SSL_ERROR_WANT_WRITE+ 3)
+(defconstant +SSL_ERROR_ZERO_RETURN+ 6)
+(defconstant +SSL_CTRL_MODE+ 33)
+(defconstant +SSL_MODE_ENABLE_PARTIAL_WRITE+ 1)
+(defconstant +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 2)
+(defconstant +SSL_ST_CONNECT+ #x1000)
+
+(cffi:defcfun ("SSL_connect" ssl-connect)
+ :int
+ (ssl :pointer))
+(cffi:defcfun ("SSL_accept" ssl-accept)
+ :int
+ (ssl :pointer))
+(cffi:defcfun ("SSL_write" ssl-write)
+ :int
+ (ssl :pointer)
+ (buf :pointer)
+ (num :int))
+(cffi:defcfun ("SSL_read" ssl-read)
+ :int
+ (ssl :pointer)
+ (buf :pointer)
+ (num :int))
+
+(cffi:defcfun ("SSL_set_read_ahead" ssl-set-read-ahead)
+ :void
+ (ssl :pointer)
+ (yes :int))
+
+(cffi:defcfun ("SSL_get_shutdown" ssl-get-shutdown)
+ :int
+ (ssl :pointer))
+
+(cffi:defcfun ("SSL_pending" ssl-pending)
+ :int
+ (ssl :pointer))
+
+(cffi:defcfun ("SSL_state" ssl-state)
+ :int
+ (ssl :pointer))
+
+(cffi:defcfun ("SSL_free" ssl-free)
+ :void
+ (ssl :pointer))
+(cffi:defcfun ("SSL_get_error" ssl-get-error)
+ :int
+ (ssl :pointer)
+ (ret :int))
+
+(cffi:defcfun ("SSL_load_error_strings" ssl-load-error-strings)
+ :void)
+(cffi:defcfun ("SSL_library_init" ssl-library-init)
+ :int)
+(cffi:defcfun ("SSL_CTX_new" ssl-ctx-new)
+ :pointer
+ (method :pointer))
+(cffi:defcfun ("SSLv23_method" ssl-v23-method)
+ :pointer)
+(cffi:defcfun ("SSL_new" ssl-new)
+ :pointer
+ (ctx :pointer))
+(cffi:defcfun ("SSL_set_fd" ssl-set-fd)
+ :int
+ (ssl :pointer)
+ (fd :int))
+
+(defvar *openssl-initialized* nil)
+(defvar *ssl-ctx*)
+(defun initialize-openssl ()
+ (unless *openssl-initialized*
+ (cffi:load-foreign-library 'libssl)
+ (cffi:load-foreign-library 'libeay32)
+ (ssl-library-init)
+ (ssl-load-error-strings)
+ (setf *ssl-ctx* (ssl-ctx-new (ssl-v23-method))
+ *openssl-initialized* t)))
+
+(defun ssl-ctx-set-mode (context mode)
+ (ssl-ctx-ctrl context +SSL_CTRL_MODE+ mode (cffi:null-pointer)))
View
@@ -0,0 +1,105 @@
+(in-package #:tpd2.io)
+
+(defstruct ssl-socket
+ transport
+ ssl
+ (event-wanted 0)
+ state)
+
+(cffi:defcfun ("SSL_CTX_ctrl" ssl-ctx-ctrl)
+ :long
+ (ssl-ctx :pointer)
+ (cmd :int)
+ (larg :long)
+ (parg :pointer))
+
+(defun ssl-socket-init (ss)
+ (initialize-openssl)
+ (let ((context *ssl-ctx*))
+ (ssl-ctx-set-mode context +SSL_MODE_ENABLE_PARTIAL_WRITE+)
+ (ssl-ctx-set-mode context +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+)
+ (setf (ssl-socket-ssl ss) (ssl-new context)))
+
+ (ssl-set-fd (ssl-socket-ssl ss) (ssl-socket-transport ss))
+ (setf (ssl-socket-state ss) 'connect)
+
+ (let ((socket (ssl-socket-ssl ss)))
+ (trivial-garbage:finalize ss (lambda()
+ (ssl-free socket)))))
+
+(defun convert-con-to-ssl (con)
+ (let ((ss (make-ssl-socket :transport (con-socket con))))
+ (ssl-socket-init ss)
+ (setf (con-socket con) ss)
+ con))
+
+(define-condition ssl-error (socket-error)
+ ((call-name :initarg :call-name :initform nil)
+ (return-code :initarg :rc :initform nil)
+ (ssl-error-code :initarg :ssl-error-code :initform nil)
+ (errno :initform errno)))
+
+(defmethod print-object ((ss ssl-error) stream)
+ (print-unreadable-object (ss stream :identity t)
+ (with-slots (call-name return-code ssl-error-code errno) ss
+ (format stream "~A returned ~A; SSL_Get_Error ~A; errno ~A"
+ call-name return-code ssl-error-code errno))))
+
+(defun ssl-socket-check-error (ss rc call-name)
+ (when (> 0 rc)
+ (case (ssl-get-error (ssl-socket-ssl ss) rc)
+ (#.+SSL_ERROR_NONE+ nil)
+ (#.+SSL_ERROR_WANT_READ+ (setf (ssl-socket-event-wanted ss) +POLLIN+))
+ (#.+SSL_ERROR_WANT_WRITE+ (setf (ssl-socket-event-wanted ss) +POLLOUT+))
+ (otherwise
+ (error 'ssl-error :call-name call-name :rc rc :ssl-error-code (ssl-get-error (ssl-socket-ssl ss) rc))))))
+
+(defun ssl-socket-process-state (ss)
+ (setf (ssl-socket-event-wanted ss) 0)
+ (ecase (ssl-socket-state ss)
+ (connect
+ (unless
+ (or
+ (ssl-socket-check-error ss (ssl-connect (ssl-socket-ssl ss)) "SSL_Connect")
+ (eq +SSL_ST_CONNECT+ (ssl-state (ssl-socket-ssl ss))))
+ (setf (ssl-socket-state ss) 'running)))
+ (running
+ nil))
+ (not (eq (ssl-socket-state ss) 'running)))
+
+(defmethod socket-write ((ss ssl-socket) buf offset)
+ (unless (ssl-socket-process-state ss)
+ (let ((written
+ (cffi:with-pointer-to-vector-data (out-ptr buf)
+ (ssl-write (ssl-socket-ssl ss) (cffi:inc-pointer out-ptr offset) (- (length buf) offset)))))
+ (ssl-socket-check-error ss written "SSL_Write")
+ (when (> written 0)
+ written))))
+
+(defmethod socket-read ((ss ssl-socket) buf offset)
+ (unless (ssl-socket-process-state ss)
+ (let ((amount
+ (cffi:with-pointer-to-vector-data (in-ptr buf)
+ (ssl-read (ssl-socket-ssl ss) (cffi:inc-pointer in-ptr offset) (- (length buf) offset)))))
+ (ssl-socket-check-error ss amount "SSL_Read")
+ (cond ((and (zerop amount)
+ (eql (ssl-get-error (ssl-socket-ssl ss) 0) +SSL_ERROR_ZERO_RETURN+))
+ 0)
+ ((> amount 0) amount)
+ (t nil)))))
+
+(defmethod socket-peer ((ss ssl-socket))
+ (socket-peer (ssl-socket-transport ss)))
+
+(defmethod socket-close ((ss ssl-socket))
+ (awhen (ssl-socket-transport ss)
+ (setf (ssl-socket-transport ss) nil)
+ (socket-close it)))
+
+(defmethod socket-register ((ss ssl-socket) events con)
+ (debug-assert (eql ss (con-socket con)) (ss con))
+ (register-fd (ssl-socket-transport ss)
+ (if (zerop (ssl-socket-event-wanted ss))
+ events
+ (ssl-socket-event-wanted ss))
+ con))

0 comments on commit 44dcc24

Please sign in to comment.