Skip to content

Commit 44dcc24

Browse files
viivii
committed
Add support for client side HTTPS via OpenSSL (connection pooling working)
1 parent 3eb1330 commit 44dcc24

File tree

2 files changed

+204
-0
lines changed

2 files changed

+204
-0
lines changed

‎src/io/openssl.lisp‎

Lines changed: 99 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,99 @@
1+
(in-package #:tpd2.io)
2+
3+
;; FFI for OpenSSL library
4+
5+
(eval-when (:compile-toplevel :load-toplevel :execute)
6+
(cffi:define-foreign-library libssl
7+
(:unix "libssl.so")
8+
(t (:default "libssl3")))
9+
10+
(cffi:use-foreign-library libssl)
11+
12+
#+freebsd
13+
(progn
14+
(cffi:define-foreign-library libcrypto
15+
(:unix (:or "libcrypto.so" "/usr/local/lib/libcrypto.so"))
16+
(t (:default "libcrypto")))
17+
(cffi:use-foreign-library libcrypto)))
18+
19+
(defconstant +SSL_ERROR_NONE+ 0)
20+
(defconstant +SSL_ERROR_WANT_READ+ 2)
21+
(defconstant +SSL_ERROR_WANT_WRITE+ 3)
22+
(defconstant +SSL_ERROR_ZERO_RETURN+ 6)
23+
(defconstant +SSL_CTRL_MODE+ 33)
24+
(defconstant +SSL_MODE_ENABLE_PARTIAL_WRITE+ 1)
25+
(defconstant +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 2)
26+
(defconstant +SSL_ST_CONNECT+ #x1000)
27+
28+
(cffi:defcfun ("SSL_connect" ssl-connect)
29+
:int
30+
(ssl :pointer))
31+
(cffi:defcfun ("SSL_accept" ssl-accept)
32+
:int
33+
(ssl :pointer))
34+
(cffi:defcfun ("SSL_write" ssl-write)
35+
:int
36+
(ssl :pointer)
37+
(buf :pointer)
38+
(num :int))
39+
(cffi:defcfun ("SSL_read" ssl-read)
40+
:int
41+
(ssl :pointer)
42+
(buf :pointer)
43+
(num :int))
44+
45+
(cffi:defcfun ("SSL_set_read_ahead" ssl-set-read-ahead)
46+
:void
47+
(ssl :pointer)
48+
(yes :int))
49+
50+
(cffi:defcfun ("SSL_get_shutdown" ssl-get-shutdown)
51+
:int
52+
(ssl :pointer))
53+
54+
(cffi:defcfun ("SSL_pending" ssl-pending)
55+
:int
56+
(ssl :pointer))
57+
58+
(cffi:defcfun ("SSL_state" ssl-state)
59+
:int
60+
(ssl :pointer))
61+
62+
(cffi:defcfun ("SSL_free" ssl-free)
63+
:void
64+
(ssl :pointer))
65+
(cffi:defcfun ("SSL_get_error" ssl-get-error)
66+
:int
67+
(ssl :pointer)
68+
(ret :int))
69+
70+
(cffi:defcfun ("SSL_load_error_strings" ssl-load-error-strings)
71+
:void)
72+
(cffi:defcfun ("SSL_library_init" ssl-library-init)
73+
:int)
74+
(cffi:defcfun ("SSL_CTX_new" ssl-ctx-new)
75+
:pointer
76+
(method :pointer))
77+
(cffi:defcfun ("SSLv23_method" ssl-v23-method)
78+
:pointer)
79+
(cffi:defcfun ("SSL_new" ssl-new)
80+
:pointer
81+
(ctx :pointer))
82+
(cffi:defcfun ("SSL_set_fd" ssl-set-fd)
83+
:int
84+
(ssl :pointer)
85+
(fd :int))
86+
87+
(defvar *openssl-initialized* nil)
88+
(defvar *ssl-ctx*)
89+
(defun initialize-openssl ()
90+
(unless *openssl-initialized*
91+
(cffi:load-foreign-library 'libssl)
92+
(cffi:load-foreign-library 'libeay32)
93+
(ssl-library-init)
94+
(ssl-load-error-strings)
95+
(setf *ssl-ctx* (ssl-ctx-new (ssl-v23-method))
96+
*openssl-initialized* t)))
97+
98+
(defun ssl-ctx-set-mode (context mode)
99+
(ssl-ctx-ctrl context +SSL_CTRL_MODE+ mode (cffi:null-pointer)))

‎src/io/ssl.lisp‎

Lines changed: 105 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,105 @@
1+
(in-package #:tpd2.io)
2+
3+
(defstruct ssl-socket
4+
transport
5+
ssl
6+
(event-wanted 0)
7+
state)
8+
9+
(cffi:defcfun ("SSL_CTX_ctrl" ssl-ctx-ctrl)
10+
:long
11+
(ssl-ctx :pointer)
12+
(cmd :int)
13+
(larg :long)
14+
(parg :pointer))
15+
16+
(defun ssl-socket-init (ss)
17+
(initialize-openssl)
18+
(let ((context *ssl-ctx*))
19+
(ssl-ctx-set-mode context +SSL_MODE_ENABLE_PARTIAL_WRITE+)
20+
(ssl-ctx-set-mode context +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+)
21+
(setf (ssl-socket-ssl ss) (ssl-new context)))
22+
23+
(ssl-set-fd (ssl-socket-ssl ss) (ssl-socket-transport ss))
24+
(setf (ssl-socket-state ss) 'connect)
25+
26+
(let ((socket (ssl-socket-ssl ss)))
27+
(trivial-garbage:finalize ss (lambda()
28+
(ssl-free socket)))))
29+
30+
(defun convert-con-to-ssl (con)
31+
(let ((ss (make-ssl-socket :transport (con-socket con))))
32+
(ssl-socket-init ss)
33+
(setf (con-socket con) ss)
34+
con))
35+
36+
(define-condition ssl-error (socket-error)
37+
((call-name :initarg :call-name :initform nil)
38+
(return-code :initarg :rc :initform nil)
39+
(ssl-error-code :initarg :ssl-error-code :initform nil)
40+
(errno :initform errno)))
41+
42+
(defmethod print-object ((ss ssl-error) stream)
43+
(print-unreadable-object (ss stream :identity t)
44+
(with-slots (call-name return-code ssl-error-code errno) ss
45+
(format stream "~A returned ~A; SSL_Get_Error ~A; errno ~A"
46+
call-name return-code ssl-error-code errno))))
47+
48+
(defun ssl-socket-check-error (ss rc call-name)
49+
(when (> 0 rc)
50+
(case (ssl-get-error (ssl-socket-ssl ss) rc)
51+
(#.+SSL_ERROR_NONE+ nil)
52+
(#.+SSL_ERROR_WANT_READ+ (setf (ssl-socket-event-wanted ss) +POLLIN+))
53+
(#.+SSL_ERROR_WANT_WRITE+ (setf (ssl-socket-event-wanted ss) +POLLOUT+))
54+
(otherwise
55+
(error 'ssl-error :call-name call-name :rc rc :ssl-error-code (ssl-get-error (ssl-socket-ssl ss) rc))))))
56+
57+
(defun ssl-socket-process-state (ss)
58+
(setf (ssl-socket-event-wanted ss) 0)
59+
(ecase (ssl-socket-state ss)
60+
(connect
61+
(unless
62+
(or
63+
(ssl-socket-check-error ss (ssl-connect (ssl-socket-ssl ss)) "SSL_Connect")
64+
(eq +SSL_ST_CONNECT+ (ssl-state (ssl-socket-ssl ss))))
65+
(setf (ssl-socket-state ss) 'running)))
66+
(running
67+
nil))
68+
(not (eq (ssl-socket-state ss) 'running)))
69+
70+
(defmethod socket-write ((ss ssl-socket) buf offset)
71+
(unless (ssl-socket-process-state ss)
72+
(let ((written
73+
(cffi:with-pointer-to-vector-data (out-ptr buf)
74+
(ssl-write (ssl-socket-ssl ss) (cffi:inc-pointer out-ptr offset) (- (length buf) offset)))))
75+
(ssl-socket-check-error ss written "SSL_Write")
76+
(when (> written 0)
77+
written))))
78+
79+
(defmethod socket-read ((ss ssl-socket) buf offset)
80+
(unless (ssl-socket-process-state ss)
81+
(let ((amount
82+
(cffi:with-pointer-to-vector-data (in-ptr buf)
83+
(ssl-read (ssl-socket-ssl ss) (cffi:inc-pointer in-ptr offset) (- (length buf) offset)))))
84+
(ssl-socket-check-error ss amount "SSL_Read")
85+
(cond ((and (zerop amount)
86+
(eql (ssl-get-error (ssl-socket-ssl ss) 0) +SSL_ERROR_ZERO_RETURN+))
87+
0)
88+
((> amount 0) amount)
89+
(t nil)))))
90+
91+
(defmethod socket-peer ((ss ssl-socket))
92+
(socket-peer (ssl-socket-transport ss)))
93+
94+
(defmethod socket-close ((ss ssl-socket))
95+
(awhen (ssl-socket-transport ss)
96+
(setf (ssl-socket-transport ss) nil)
97+
(socket-close it)))
98+
99+
(defmethod socket-register ((ss ssl-socket) events con)
100+
(debug-assert (eql ss (con-socket con)) (ss con))
101+
(register-fd (ssl-socket-transport ss)
102+
(if (zerop (ssl-socket-event-wanted ss))
103+
events
104+
(ssl-socket-event-wanted ss))
105+
con))

0 commit comments

Comments
 (0)