235 lines
6.0 KiB
Common Lisp
235 lines
6.0 KiB
Common Lisp
;;; Copyright (C) 2001, 2003 Eric Marsden
|
|
;;; Copyright (C) 2005 David Lichteblau
|
|
;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
|
|
;;;
|
|
;;; See LICENSE for details.
|
|
|
|
(declaim
|
|
(optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0)))
|
|
|
|
(in-package :cl+ssl)
|
|
|
|
|
|
;;; Global state
|
|
;;;
|
|
(defvar *ssl-global-context* nil)
|
|
(defvar *ssl-global-method* nil)
|
|
(defvar *bio-lisp-method* nil)
|
|
|
|
(defun ssl-initialized-p ()
|
|
(and *ssl-global-context* *ssl-global-method*))
|
|
|
|
|
|
;;; Constants
|
|
;;;
|
|
(defconstant +random-entropy+ 256)
|
|
|
|
(defconstant +ssl-filetype-pem+ 1)
|
|
(defconstant +ssl-filetype-asn1+ 2)
|
|
(defconstant +ssl-filetype-default+ 3)
|
|
|
|
(defconstant +SSL_CTRL_SET_SESS_CACHE_MODE+ 44)
|
|
|
|
|
|
;;; Function definitions
|
|
;;;
|
|
(declaim (inline ssl-write ssl-read ssl-connect ssl-accept))
|
|
|
|
(cffi:defctype ssl-method :pointer)
|
|
(cffi:defctype ssl-ctx :pointer)
|
|
(cffi:defctype ssl-pointer :pointer)
|
|
|
|
(cffi:defcfun ("SSL_get_version" ssl-get-version)
|
|
:string
|
|
(ssl ssl-pointer))
|
|
(cffi:defcfun ("SSL_load_error_strings" ssl-load-error-strings)
|
|
:void)
|
|
(cffi:defcfun ("SSL_library_init" ssl-library-init)
|
|
:int)
|
|
(cffi:defcfun ("SSLv2_client_method" ssl-v2-client-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("SSLv23_client_method" ssl-v23-client-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("SSLv23_server_method" ssl-v23-server-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("SSLv23_method" ssl-v23-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("SSLv3_client_method" ssl-v3-client-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("SSLv3_server_method" ssl-v3-server-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("SSLv3_method" ssl-v3-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("TLSv1_client_method" ssl-TLSv1-client-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("TLSv1_server_method" ssl-TLSv1-server-method)
|
|
ssl-method)
|
|
(cffi:defcfun ("TLSv1_method" ssl-TLSv1-method)
|
|
ssl-method)
|
|
|
|
(cffi:defcfun ("SSL_CTX_new" ssl-ctx-new)
|
|
ssl-ctx
|
|
(method ssl-method))
|
|
(cffi:defcfun ("SSL_new" ssl-new)
|
|
ssl-pointer
|
|
(ctx ssl-ctx))
|
|
(cffi:defcfun ("SSL_set_fd" ssl-set-fd)
|
|
:int
|
|
(ssl ssl-pointer)
|
|
(fd :int))
|
|
(cffi:defcfun ("SSL_set_bio" ssl-set-bio)
|
|
:void
|
|
(ssl ssl-pointer)
|
|
(rbio :pointer)
|
|
(wbio :pointer))
|
|
(cffi:defcfun ("SSL_get_error" ssl-get-error)
|
|
:int
|
|
(ssl ssl-pointer)
|
|
(ret :int))
|
|
(cffi:defcfun ("SSL_set_connect_state" ssl-set-connect-state)
|
|
:void
|
|
(ssl ssl-pointer))
|
|
(cffi:defcfun ("SSL_set_accept_state" ssl-set-accept-state)
|
|
:void
|
|
(ssl ssl-pointer))
|
|
(cffi:defcfun ("SSL_connect" ssl-connect)
|
|
:int
|
|
(ssl ssl-pointer))
|
|
(cffi:defcfun ("SSL_accept" ssl-accept)
|
|
:int
|
|
(ssl ssl-pointer))
|
|
(cffi:defcfun ("SSL_write" ssl-write)
|
|
:int
|
|
(ssl ssl-pointer)
|
|
(buf :pointer)
|
|
(num :int))
|
|
(cffi:defcfun ("SSL_read" ssl-read)
|
|
:int
|
|
(ssl ssl-pointer)
|
|
(buf :pointer)
|
|
(num :int))
|
|
(cffi:defcfun ("SSL_shutdown" ssh-shutdown)
|
|
:void
|
|
(ssl ssl-pointer))
|
|
(cffi:defcfun ("SSL_free" ssl-free)
|
|
:void
|
|
(ssl ssl-pointer))
|
|
(cffi:defcfun ("SSL_CTX_free" ssl-ctx-free)
|
|
:void
|
|
(ctx ssl-ctx))
|
|
(cffi:defcfun ("RAND_seed" rand-seed)
|
|
:void
|
|
(buf :pointer)
|
|
(num :int))
|
|
(cffi:defcfun ("BIO_ctrl" bio-set-fd)
|
|
:long
|
|
(bio :pointer)
|
|
(cmd :int)
|
|
(larg :long)
|
|
(parg :pointer))
|
|
(cffi:defcfun ("BIO_new_socket" bio-new-socket)
|
|
:pointer
|
|
(fd :int)
|
|
(close-flag :int))
|
|
(cffi:defcfun ("BIO_new" bio-new)
|
|
:pointer
|
|
(method :pointer))
|
|
|
|
(cffi:defcfun ("ERR_get_error" err-get-error)
|
|
:unsigned-long)
|
|
(cffi:defcfun ("ERR_error_string" err-error-string)
|
|
:string
|
|
(e :unsigned-long)
|
|
(buf :pointer))
|
|
|
|
(cffi:defcfun ("SSL_set_cipher_list" ssl-set-cipher-list)
|
|
:int
|
|
(ssl ssl-pointer)
|
|
(str :string))
|
|
(cffi:defcfun ("SSL_use_RSAPrivateKey_file" ssl-use-rsa-privatekey-file)
|
|
:int
|
|
(ssl ssl-pointer)
|
|
(str :string)
|
|
;; either +ssl-filetype-pem+ or +ssl-filetype-asn1+
|
|
(type :int))
|
|
(cffi:defcfun
|
|
("SSL_CTX_use_RSAPrivateKey_file" ssl-ctx-use-rsa-privatekey-file)
|
|
:int
|
|
(ctx ssl-ctx)
|
|
(type :int))
|
|
(cffi:defcfun ("SSL_use_certificate_file" ssl-use-certificate-file)
|
|
:int
|
|
(ssl ssl-pointer)
|
|
(str :string)
|
|
(type :int))
|
|
(cffi:defcfun ("SSL_CTX_load_verify_locations" ssl-ctx-load-verify-locations)
|
|
:int
|
|
(ctx ssl-ctx)
|
|
(CAfile :string)
|
|
(CApath :string))
|
|
(cffi:defcfun ("SSL_CTX_set_client_CA_list" ssl-ctx-set-client-ca-list)
|
|
:void
|
|
(ctx ssl-ctx)
|
|
(list ssl-pointer))
|
|
(cffi:defcfun ("SSL_load_client_CA_file" ssl-load-client-ca-file)
|
|
ssl-pointer
|
|
(file :string))
|
|
|
|
(cffi:defcfun ("SSL_CTX_ctrl" ssl-ctx-ctrl)
|
|
:long
|
|
(ctx ssl-ctx)
|
|
(cmd :int)
|
|
(larg :long)
|
|
(parg :long))
|
|
|
|
|
|
;;; Funcall wrapper
|
|
;;;
|
|
(defvar *socket*)
|
|
|
|
(declaim (inline ensure-ssl-funcall))
|
|
(defun ensure-ssl-funcall (*socket* handle func sleep-time &rest args)
|
|
(loop
|
|
(handler-case
|
|
(let ((rc (apply func args)))
|
|
(when (plusp rc)
|
|
(return rc))
|
|
(ssl-signal-error handle func (ssl-get-error handle rc) rc))
|
|
(ssl-error-want-something (condition)
|
|
(declare (ignore condition))
|
|
;; FIXME: what is this SLEEP business for?
|
|
;; Do we still need this?
|
|
(warn "sleeping in ensure-ssl-funcall")
|
|
(sleep sleep-time)))))
|
|
|
|
|
|
;;; Initialization
|
|
;;;
|
|
(defun init-prng ()
|
|
;; this initialization of random entropy is not necessary on
|
|
;; Linux, since the OpenSSL library automatically reads from
|
|
;; /dev/urandom if it exists. On Solaris it is necessary.
|
|
(let ((buf (cffi-sys::make-shareable-byte-vector +random-entropy+)))
|
|
(dotimes (i +random-entropy+)
|
|
(setf (elt buf i) (random 256)))
|
|
(cffi-sys::with-pointer-to-vector-data (ptr buf)
|
|
(rand-seed ptr +random-entropy+))))
|
|
|
|
(defun ssl-ctx-set-session-cache-mode (ctx mode)
|
|
(ssl-ctx-ctrl ctx +SSL_CTRL_SET_SESS_CACHE_MODE+ mode 0))
|
|
|
|
(defun initialize (&optional (method 'ssl-v23-method))
|
|
(setf *bio-lisp-method* (make-bio-lisp-method))
|
|
(ssl-load-error-strings)
|
|
(ssl-library-init)
|
|
(init-prng)
|
|
(setf *ssl-global-method* (funcall method))
|
|
(setf *ssl-global-context* (ssl-ctx-new *ssl-global-method*))
|
|
(ssl-ctx-set-session-cache-mode *ssl-global-context* 3))
|
|
|
|
(defun ensure-initialized (&optional (method 'ssl-v23-method))
|
|
(unless (ssl-initialized-p)
|
|
(initialize method))
|
|
(unless *bio-lisp-method*
|
|
(setf *bio-lisp-method* (make-bio-lisp-method))))
|