From 343a215d31327870de4cc7cc0c2bda78b8457c48 Mon Sep 17 00:00:00 2001 From: dlichteblau Date: Wed, 9 Nov 2005 22:10:44 +0000 Subject: [PATCH] Initial revision --- LICENSE | 17 ++++ Makefile | 3 + bio.lisp | 137 ++++++++++++++++++++++++++++ cl+ssl.asd | 26 ++++++ conditions.lisp | 211 +++++++++++++++++++++++++++++++++++++++++++ ffi.lisp | 234 ++++++++++++++++++++++++++++++++++++++++++++++++ index.css | 66 ++++++++++++++ index.html | 199 ++++++++++++++++++++++++++++++++++++++++ package.lisp | 13 +++ reload.lisp | 17 ++++ streams.lisp | 171 +++++++++++++++++++++++++++++++++++ test.lisp | 95 ++++++++++++++++++++ 12 files changed, 1189 insertions(+) create mode 100644 LICENSE create mode 100644 Makefile create mode 100644 bio.lisp create mode 100644 cl+ssl.asd create mode 100644 conditions.lisp create mode 100644 ffi.lisp create mode 100644 index.css create mode 100644 index.html create mode 100644 package.lisp create mode 100644 reload.lisp create mode 100644 streams.lisp create mode 100644 test.lisp diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..bf7273a --- /dev/null +++ b/LICENSE @@ -0,0 +1,17 @@ +;; Copyright (C) 2001, 2003 Eric Marsden +;; Copyright (C) 2005 David Lichteblau +;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Library General Public +;; License as published by the Free Software Foundation; either +;; version 2 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Library General Public License for more details. +;; +;; You should have received a copy of the GNU Library General Public +;; License along with this library; if not, write to the Free +;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..f6d297c --- /dev/null +++ b/Makefile @@ -0,0 +1,3 @@ +.PHONY: clean +clean: + rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl diff --git a/bio.lisp b/bio.lisp new file mode 100644 index 0000000..1010342 --- /dev/null +++ b/bio.lisp @@ -0,0 +1,137 @@ +;;; Copyright (C) 2005 David Lichteblau +;;; +;;; See LICENSE for details. + +(in-package cl+ssl) + +(defconstant +bio-type-socket+ (logior 5 #x0400 #x0100)) +(defconstant +BIO_FLAGS_READ+ 1) +(defconstant +BIO_FLAGS_WRITE+ 2) +(defconstant +BIO_FLAGS_SHOULD_RETRY+ 8) +(defconstant +BIO_CTRL_FLUSH+ 11) + +(cffi:defcstruct bio-method + (type :int) + (name :pointer) + (bwrite :pointer) + (bread :pointer) + (bputs :pointer) + (bgets :pointer) + (ctrl :pointer) + (create :pointer) + (destroy :pointer) + (callback-ctrl :pointer)) + +(cffi:defcstruct bio + (method :pointer) + (callback :pointer) + (cb-arg :pointer) + (init :int) + (shutdown :int) + (flags :int) + (retry-reason :int) + (num :int) + (ptr :pointer) + (next-bio :pointer) + (prev-bio :pointer) + (references :int) + (num-read :unsigned-long) + (num-write :unsigned-long) + (crypto-ex-data-stack :pointer) + (crypto-ex-data-dummy :int)) + +(defun make-bio-lisp-method () + (let ((m (cffi:foreign-alloc 'bio-method))) + (setf (cffi:foreign-slot-value m 'bio-method 'type) + ;; fixme: this is wrong, but presumably still better than some + ;; random value here. + +bio-type-socket+) + (macrolet ((slot (name) + `(cffi:foreign-slot-value m 'bio-method ,name))) + (setf (slot 'name) (cffi:foreign-string-alloc "lisp")) + (setf (slot 'bwrite) (cffi:callback lisp-write)) + (setf (slot 'bread) (cffi:callback lisp-read)) + (setf (slot 'bputs) (cffi:callback lisp-puts)) + (setf (slot 'bgets) (cffi:null-ptr)) + (setf (slot 'ctrl) (cffi:callback lisp-ctrl)) + (setf (slot 'create) (cffi:callback lisp-create)) + (setf (slot 'destroy) (cffi:callback lisp-destroy)) + (setf (slot 'callback-ctrl) (cffi:null-ptr))) + m)) + +(defun bio-new-lisp () + (bio-new *bio-lisp-method*)) + + +;;; "cargo cult" + +(cffi:defcallback lisp-write :int ((bio :pointer) (buf :pointer) (n :int)) + bio + (dotimes (i n) + (write-byte (cffi:mem-ref buf :unsigned-char i) *socket*)) + (finish-output *socket*) + n) + +(defun clear-retry-flags (bio) + (setf (cffi:foreign-slot-value bio 'bio 'flags) + (logandc2 (cffi:foreign-slot-value bio 'bio 'flags) + (logior +BIO_FLAGS_READ+ + +BIO_FLAGS_WRITE+ + +BIO_FLAGS_SHOULD_RETRY+)))) + +(defun set-retry-read (bio) + (setf (cffi:foreign-slot-value bio 'bio 'flags) + (logior (cffi:foreign-slot-value bio 'bio 'flags) + +BIO_FLAGS_READ+ + +BIO_FLAGS_SHOULD_RETRY+))) + +;; not sure whether we should block or not... +(defvar *block* t) + +(cffi:defcallback lisp-read :int ((bio :pointer) (buf :pointer) (n :int)) + bio buf n + (let ((i 0)) + (handler-case + (unless (or (cffi:null-ptr-p buf) (null n)) + (clear-retry-flags bio) + (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*)) + (incf i) + (loop + while (and (< i n) (or *block* (listen *socket*))) + do + (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*)) + (incf i)) + #+(or) + (when (zerop i) (set-retry-read bio))) + (end-of-file ())) + i)) + +(cffi:defcallback lisp-puts :int ((bio :pointer) (buf :string)) + bio buf + (error "lisp-puts not implemented")) + +(cffi:defcallback lisp-ctrl :int + ((bio :pointer) (cmd :int) (larg :long) (parg :pointer)) + bio larg parg + (cond + ((eql cmd +BIO_CTRL_FLUSH+) 1) + (t + ;; (warn "lisp-ctrl(~A,~A,~A)" cmd larg parg) + 0))) + +(cffi:defcallback lisp-create :int ((bio :pointer)) + (setf (cffi:foreign-slot-value bio 'bio 'init) 1) + (setf (cffi:foreign-slot-value bio 'bio 'num) 0) + (setf (cffi:foreign-slot-value bio 'bio 'ptr) (cffi:null-ptr)) + (setf (cffi:foreign-slot-value bio 'bio 'flags) 0) + 1) + +(cffi:defcallback lisp-destroy :int ((bio :pointer)) + (cond + ((cffi:null-ptr-p bio) 0) + (t + (setf (cffi:foreign-slot-value bio 'bio 'init) 0) + (setf (cffi:foreign-slot-value bio 'bio 'flags) 0) + 1))) + +(setf *bio-lisp-method* nil) ;force reinit if anything changed here diff --git a/cl+ssl.asd b/cl+ssl.asd new file mode 100644 index 0000000..2b09589 --- /dev/null +++ b/cl+ssl.asd @@ -0,0 +1,26 @@ +;;; -*- mode: 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. + +(defpackage :cl+ssl-system + (:use :cl :asdf) + (:export #:*libssl-pathname*)) + +(in-package :cl+ssl-system) + +(defparameter *libssl-pathname* "/usr/lib/libssl.so") + +(defsystem :cl+ssl + :depends-on (:cffi :trivial-gray-streams) + :serial t + :components + ((:file "reload") + (:file "package") + (:file "conditions") + (:file "ffi") + (:file "streams") + (:file "bio"))) diff --git a/conditions.lisp b/conditions.lisp new file mode 100644 index 0000000..dd44dc2 --- /dev/null +++ b/conditions.lisp @@ -0,0 +1,211 @@ +;;; 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. + +(in-package :cl+ssl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +ssl-error-none+ 0) + (defconstant +ssl-error-ssl+ 1) + (defconstant +ssl-error-want-read+ 2) + (defconstant +ssl-error-want-write+ 3) + (defconstant +ssl-error-want-x509-lookup+ 4) + (defconstant +ssl-error-syscall+ 5) + (defconstant +ssl-error-zero-return+ 6) + (defconstant +ssl-error-want-connect+ 7)) + + +;;; Condition hierarchy +;;; +(define-condition ssl-error (error) + ((queue :initform nil :initarg :queue :reader ssl-error-queue))) + +(define-condition ssl-error/handle (ssl-error) + ((ret :initarg :ret + :reader ssl-error-ret) + (handle :initarg :handle + :reader ssl-error-handle)) + (:report (lambda (condition stream) + (format stream "Unspecified error ~A on handle ~A" + (ssl-error-ret condition) + (ssl-error-handle condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +(define-condition ssl-error-initialize (ssl-error) + ((reason :initarg :reason + :reader ssl-error-reason)) + (:report (lambda (condition stream) + (format stream "SSL initialization error: ~A" + (ssl-error-reason condition)) + (write-sequence (ssl-error-queue condition) stream)))) + + +(define-condition ssl-error-want-something (ssl-error/handle) + ()) + +;;;SSL_ERROR_NONE +(define-condition ssl-error-none (ssl-error/handle) + () + (:documentation + "The TLS/SSL I/O operation completed. This result code is returned if and + only if ret > 0.") + (:report (lambda (condition stream) + (format stream "The TLS/SSL operation on handle ~A completed. (return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +;; SSL_ERROR_ZERO_RETURN +(define-condition ssl-error-zero-return (ssl-error/handle) + () + (:documentation + "The TLS/SSL connection has been closed. If the protocol version is SSL 3.0 + or TLS 1.0, this result code is returned only if a closure alert has + occurred in the protocol, i.e. if the connection has been closed cleanly. + Note that in this case SSL_ERROR_ZERO_RETURN + does not necessarily indicate that the underlying transport has been + closed.") + (:report (lambda (condition stream) + (format stream "The TLS/SSL connection on handle ~A has been closed. (return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +;; SSL_ERROR_WANT_READ +(define-condition ssl-error-want-read (ssl-error-want-something) + () + (:documentation + "The operation did not complete; the same TLS/SSL I/O function should be + called again later. If, by then, the underlying BIO has data available for + reading (if the result code is SSL_ERROR_WANT_READ) or allows writing data + (SSL_ERROR_WANT_WRITE), then some TLS/SSL protocol progress will take place, + i.e. at least part of an TLS/SSL record will be read or written. Note that + the retry may again lead to a SSL_ERROR_WANT_READ or SSL_ERROR_WANT_WRITE + condition. There is no fixed upper limit for the number of iterations that + may be necessary until progress becomes visible at application protocol + level.") + (:report (lambda (condition stream) + (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a READ. (return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +;; SSL_ERROR_WANT_WRITE +(define-condition ssl-error-want-write (ssl-error-want-something) + () + (:documentation + "The operation did not complete; the same TLS/SSL I/O function should be + called again later. If, by then, the underlying BIO has data available for + reading (if the result code is SSL_ERROR_WANT_READ) or allows writing data + (SSL_ERROR_WANT_WRITE), then some TLS/SSL protocol progress will take place, + i.e. at least part of an TLS/SSL record will be read or written. Note that + the retry may again lead to a SSL_ERROR_WANT_READ or SSL_ERROR_WANT_WRITE + condition. There is no fixed upper limit for the number of iterations that + may be necessary until progress becomes visible at application protocol + level.") + (:report (lambda (condition stream) + (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a WRITE. (return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +;; SSL_ERROR_WANT_CONNECT +(define-condition ssl-error-want-connect (ssl-error-want-something) + () + (:documentation + "The operation did not complete; the same TLS/SSL I/O function should be + called again later. The underlying BIO was not connected yet to the peer + and the call would block in connect()/accept(). The SSL + function should be called again when the connection is established. These + messages can only appear with a BIO_s_connect() or + BIO_s_accept() BIO, respectively. In order to find out, when + the connection has been successfully established, on many platforms + select() or poll() for writing on the socket file + descriptor can be used.") + (:report (lambda (condition stream) + (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a connect first. (return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +;; SSL_ERROR_WANT_X509_LOOKUP +(define-condition ssl-error-want-x509-lookup (ssl-error-want-something) + () + (:documentation + "The operation did not complete because an application callback set by + SSL_CTX_set_client_cert_cb() has asked to be called again. The + TLS/SSL I/O function should be called again later. Details depend on the + application.") + (:report (lambda (condition stream) + (format stream "The TLS/SSL operation on handle ~A did not complete: An application callback wants to be called again. (return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +;; SSL_ERROR_SYSCALL +(define-condition ssl-error-syscall (ssl-error/handle) + ((syscall :initarg :syscall)) + (:documentation + "Some I/O error occurred. The OpenSSL error queue may contain more + information on the error. If the error queue is empty (i.e. ERR_get_error() returns 0), + ret can be used to find out more about the error: If ret == 0, an EOF was observed that + violates the protocol. If ret == -1, the underlying BIO reported an I/O error (for socket + I/O on Unix systems, consult errno for details).") + (:report (lambda (condition stream) + (if (zerop (err-get-error)) + (case (ssl-error-ret condition) + (0 (format stream "An I/O error occurred: An unexpected EOF was observed on handle ~A. (return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition))) + (-1 (format stream "An I/O error occurred in the underlying BIO. (return code: ~A)" + (ssl-error-ret condition))) + (otherwise (format stream "An I/O error occurred: undocumented reason. (return code: ~A)" + (ssl-error-ret condition)))) + (format stream "An UNKNOWN I/O error occurred in the underlying BIO. (return code: ~A)" + (ssl-error-ret condition))) + (write-sequence (ssl-error-queue condition) stream)))) + +;; SSL_ERROR_SSL +(define-condition ssl-error-ssl (ssl-error/handle) + () + (:documentation + "A failure in the SSL library occurred, usually a protocol error. The + OpenSSL error queue contains more information on the error.") + (:report (lambda (condition stream) + (format stream + "A failure in the SSL library occurred on handle ~A. (Return code: ~A)" + (ssl-error-handle condition) + (ssl-error-ret condition)) + (write-sequence (ssl-error-queue condition) stream)))) + +(defun write-ssl-error-queue (stream) + (format stream "SSL error queue: ~%") + (loop + for error-code = (err-get-error) + until (zerop error-code) + do (format stream "~a~%" (err-error-string error-code (cffi:null-ptr))))) + +(defun ssl-signal-error (handle syscall error-code original-error) + (let ((queue (with-output-to-string (s) (write-ssl-error-queue s)))) + (if (and (eql error-code #.+ssl-error-syscall+) + (not (zerop original-error))) + (error 'ssl-error-syscall + :handle handle + :ret error-code + :queue queue + :syscall syscall) + (error (case error-code + (#.+ssl-error-none+ 'ssl-error-none) + (#.+ssl-error-ssl+ 'ssl-error-ssl) + (#.+ssl-error-want-read+ 'ssl-error-want-read) + (#.+ssl-error-want-write+ 'ssl-error-want-write) + (#.+ssl-error-want-x509-lookup+ 'ssl-error-want-x509-lookup) + (#.+ssl-error-zero-return+ 'ssl-error-zero-return) + (#.+ssl-error-want-connect+ 'ssl-error-want-connect) + (#.+ssl-error-syscall+ 'ssl-error-zero-return) + (t 'ssl-error/handle)) + :handle handle + :ret error-code + :queue queue)))) diff --git a/ffi.lisp b/ffi.lisp new file mode 100644 index 0000000..168d97b --- /dev/null +++ b/ffi.lisp @@ -0,0 +1,234 @@ +;;; 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)))) diff --git a/index.css b/index.css new file mode 100644 index 0000000..e1633d5 --- /dev/null +++ b/index.css @@ -0,0 +1,66 @@ +div.sidebar { + float: right; + background-color: #eeeeee; + border: 2pt solid black; + margin: 0em 2pt 1em 2em; + min-width: 15%; + padding: 0pt 5pt 5pt 5pt; +} + +div.sidebar ul { + padding: 0pt 0pt 0pt 1em; + margin: 0 0 1em; +} + +body { + color: #000000; + background-color: #ffffff; + margin-right: 0pt; + margin-bottom: 10%; + padding-left: 30px; +} + +h1,h2 { + background-color: darkred; + color: white; + margin-left: -30px; +} + +th { + background-color: darkred; + color: white; + text-align: left; +} + +pre { + background-color: #eeeeee; + border: solid 1px #d0d0d0; + padding: 1em; + margin-right: 10%; +} + +.def { + background-color: #ddddff; + font-weight: bold; +} + +.nomargin { + margin-bottom: 0; + margin-top: 0; +} + +.working { + background-color: #60c060; +} + +.broken { + background-color: #ff6060; +} + +.incomplete { + background-color: #ffff60; +} + +.unknown { + background-color: #cccccc; +} diff --git a/index.html b/index.html new file mode 100644 index 0000000..841fbe1 --- /dev/null +++ b/index.html @@ -0,0 +1,199 @@ + + + + + CL+SSL + + + +

CLplusSSL

+ +

Subprojects

+ + +

Download

+ 
$ export CVSROOT=:pserver:anonymous@common-lisp.net:/project/cl-plus-ssl/cvsroot
+$ cvs login
+password: anonymous
+$ cvs co cl+ssl
+$ cvs co trivial-gray-streams
+$ cvs co trivial-https
+

+ Note that you need the libssl-dev package on Debian to + load this package without manual configuration. +

+ +

+ Send bug reports to cl-plus-ssl-devel@common-lisp.net + (list + information) + or David Lichteblau. +

+ + +

CL+SSL

+ +

A simple Common Lisp interface to OpenSSL.

+ +

About

+ +

+ This library is a fork of SSL-CMUCL. The original + SSL-CMUCL source code was written by Eric Marsden and includes + contributions by Jochen Schmidt. License: LGPL. +

+ + + +

+ Comparison chart: +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + +
FFIStreamsLisp-BIO
CL+SSLCFFIgray, non-bufferingyes
CL-SSLUFFIgray, buffering [part of ACL-COMPAT]no
SSL-CMUCLCMUCL/ALIENCMUCL, non-bufferingno
+ +

API functions

+

+

Variable CL+SSL-SYSTEM:*LIBSSL-PATHNAME*
+ Full pathname of the SSL library. Defaults + to /usr/lib/libssl.so. If the default is not correct for + your system, set this variable between loading the .asd file and + load-op'ing the system. +

+

+

Function CL+SSL:MAKE-SSL-CLIENT-STREAM (stream)
+ Return an SSL stream for the client socket stream. + All reads and writes to this SSL stream will be pushed through the + SSL connection can be closed using the standard close function. +

+

+

Function CL+SSL:MAKE-SSL-SERVER-STREAM (stream &key certificate key)
+ Return an SSL stream for the server socket stream. All + reads and writes to this server stream will be pushed through the + OpenSSL library. The SSL connection can be closed using the + standard close function. +

+

+ certificate is the path to a file containing the PEM-encoded + certificate for your server. key is the path to the PEM-encoded + key for the server, which must not be associated with a + passphrase. +

+ +

Portability

+

+ CL+SSL requires CFFI with callback support. +

+

+ Test results for Linux/x86, except OpenMCL which was tested on + Linux/PPC: +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + +
Lisp ImplementationStatusComments
OpenMCLWorking
SBCLWorking
CMU CLWorking
CLISPWorkingExtremely slow?
LispWorksWorking
AllegroBrokensegfault
Corman CLUnknown
Digitool MCLUnknown
Scieneer CLUnknown
ECLUnknown
GCLUnknown
+ +

TODO

+ +

Maybe

+ + + +

trivial-https

+ +

+ trivial-https is a fork of Brian + Mastenbrook's trivial-http adding + support for HTTPS using CL+SSL. +

+ +

+ README +

+ + +

trivial-gray-streams

+ +

+ trivial-gray-streams provides an extremely thin compatibility + layer for gray streams. +

+ +

+ README +

+ + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..51b58ce --- /dev/null +++ b/package.lisp @@ -0,0 +1,13 @@ +;;; 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. + +(in-package :cl-user) + +(defpackage :cl+ssl + (:use :common-lisp :trivial-gray-streams) + (:export #:ensure-initialized + #:make-ssl-client-stream + #:make-ssl-server-stream)) diff --git a/reload.lisp b/reload.lisp new file mode 100644 index 0000000..90e8f64 --- /dev/null +++ b/reload.lisp @@ -0,0 +1,17 @@ +;;; 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. + +;;; We do this in an extra file so that it happens +;;; - after the asd file has been loaded, so that users can +;;; customize *libssl-pathname* between loading the asd and LOAD-OPing +;;; the actual sources +;;; - before ssl.lisp is loaded, which needs the library at compilation +;;; time on some implemenations +;;; - but not every time ssl.lisp is re-loaded as would happen if we +;;; put this directly into ssl.lisp + +(in-package :cl+ssl-system) +(cffi:load-foreign-library *libssl-pathname*) diff --git a/streams.lisp b/streams.lisp new file mode 100644 index 0000000..d78feea --- /dev/null +++ b/streams.lisp @@ -0,0 +1,171 @@ +;;; 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) + +(defconstant +initial-buffer-size+ 2048) + +(defclass ssl-stream + (fundamental-binary-input-stream + fundamental-binary-output-stream + fundamental-character-input-stream + fundamental-character-output-stream + trivial-gray-stream-mixin) + ((ssl-stream-socket + :initarg :socket + :accessor ssl-stream-socket) + (handle + :initform nil + :accessor ssl-stream-handle) + (io-buffer + :initform (cffi-sys::make-shareable-byte-vector +initial-buffer-size+) + :accessor ssl-stream-io-buffer))) + +(defmethod print-object ((object ssl-stream) stream) + (print-unreadable-object (object stream :type t) + (format stream "for ~A" (ssl-stream-socket object)))) + +(defclass ssl-server-stream (ssl-stream) + ((certificate + :initarg :certificate + :accessor ssl-stream-certificate) + (key + :initarg :key + :accessor ssl-stream-key))) + + +;;; binary stream implementation +;;; +(defmethod close ((stream ssl-stream) &key abort) + (declare (ignore abort)) + (ssl-free (ssl-stream-handle stream)) + (close (ssl-stream-socket stream))) + +(defmethod stream-read-byte ((stream ssl-stream)) + (let ((buf (ssl-stream-io-buffer stream))) + (handler-case + (cffi-sys::with-pointer-to-vector-data (ptr buf) + (ensure-ssl-funcall (ssl-stream-socket stream) + (ssl-stream-handle stream) + #'ssl-read + 5.5 + (ssl-stream-handle stream) + ptr + 1) + (elt buf 0)) + ;; SSL_read returns 0 on end-of-file + (ssl-error-zero-return () + :eof)))) + +(defmethod stream-write-byte ((stream ssl-stream) b) + (let ((buf (ssl-stream-io-buffer stream)) + (handle (ssl-stream-handle stream)) + (socket (ssl-stream-socket stream))) + (setf (elt buf 0) b) + (cffi-sys::with-pointer-to-vector-data (ptr buf) + (ensure-ssl-funcall socket handle #'ssl-write 0.5 handle ptr 1))) + b) + +(defmethod stream-write-sequence + ((stream ssl-stream) (thing array) + &optional (start 0) (end (length thing))) + (check-type thing (simple-array (unsigned-byte 8) (*))) + (let ((buf (ssl-stream-io-buffer stream)) + (handle (ssl-stream-handle stream)) + (socket (ssl-stream-socket stream)) + (length (- end start))) + (when (> length (length buf)) + (setf buf (cffi-sys::make-shareable-byte-vector (- end start))) + (setf (ssl-stream-io-buffer stream) buf)) + ;; unfortunately, we cannot count on being able to use THING as an + ;; argument to WITH-POINTER-TO-VECTOR-DATA, so we need to copy all data: + (replace buf thing :start2 start :end2 end) + (cffi-sys::with-pointer-to-vector-data (ptr buf) + (ensure-ssl-funcall socket handle #'ssl-write 0.5 handle ptr length)))) + + +;;; minimal character stream implementation +;;; no support for external formats, no support for unread-char +;;; +(defmethod stream-read-char ((stream ssl-stream)) + (let ((b (stream-read-byte stream))) + (if (eql b :eof) + :eof + (code-char b)))) + +(defmethod stream-write-char ((stream ssl-stream) char) + (stream-write-byte stream (char-code char)) + char) + +(defmethod stream-write-sequence + ((stream ssl-stream) (thing string) &optional start end) + (let ((bytes (map '(simple-array (unsigned-byte 8) (*)) #'char-code thing))) + (stream-write-sequence stream bytes start end))) + +(defmethod stream-line-column ((stream ssl-stream)) + nil) + +(defmethod stream-listen ((stream ssl-stream)) + (warn "stream-listen") + (call-next-method)) + +(defmethod stream-read-char-no-hang ((stream ssl-stream)) + (warn "stream-read-char-no-hang") + (call-next-method)) + +(defmethod stream-peek-char ((stream ssl-stream)) + (warn "stream-peek-char") + (call-next-method)) + + +;;; interface functions +;;; +(defun make-ssl-client-stream (socket &key (method 'ssl-v23-method)) + "Returns an SSL stream for the client socket descriptor SOCKET." + (ensure-initialized method) + (let ((stream (make-instance 'ssl-stream :socket socket)) + (handle (ssl-new *ssl-global-context*))) + (setf (ssl-stream-handle stream) handle) + ;; (let ((bio (bio-new-socket socket 0))) (ssl-set-bio handle bio bio)) + (ssl-set-bio handle (bio-new-lisp) (bio-new-lisp)) + (ssl-set-connect-state handle) + (ensure-ssl-funcall socket handle #'ssl-connect 0.25 handle) + stream)) + +(defun make-ssl-server-stream + (socket &key certificate key (method 'ssl-v23-method)) + "Returns an SSL stream for the server socket descriptor SOCKET. +CERTIFICATE is the path to a file containing the PEM-encoded certificate for + your server. KEY is the path to the PEM-encoded key for the server, which +must not be associated with a passphrase." + (ensure-initialized method) + (let ((stream (make-instance 'ssl-server-stream + :socket socket + :certificate certificate + :key key)) + (handle (ssl-new *ssl-global-context*)) + (bio (bio-new-lisp))) + (setf (ssl-stream-handle stream) handle) + (ssl-set-bio handle bio bio) + (ssl-set-accept-state handle) + (when (zerop (ssl-set-cipher-list handle "ALL")) + (error 'ssl-error-initialize :reason "Can't set SSL cipher list")) + (when key + (unless (eql 1 (ssl-use-rsa-privatekey-file handle + key + +ssl-filetype-pem+)) + (error 'ssl-error-initialize :reason "Can't load RSA private key ~A"))) + (when certificate + (unless (eql 1 (ssl-use-certificate-file handle + certificate + +ssl-filetype-pem+)) + (error 'ssl-error-initialize + :reason "Can't load certificate ~A" certificate))) + (ensure-ssl-funcall socket handle #'ssl-accept 0.25 handle) + stream)) diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..3b89f8b --- /dev/null +++ b/test.lisp @@ -0,0 +1,95 @@ +;;; 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. + +#| +(load "test.lisp") +(ssl-test::test-https-client "www.google.com") +(ssl-test::test-https-server) +|# + +(defpackage :ssl-test + (:use :cl)) +(in-package :ssl-test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (asdf:operate 'asdf:load-op :trivial-sockets)) + +(defun read-line-crlf (stream &optional eof-error-p) + (let ((s (make-string-output-stream))) + (loop + for empty = t then nil + for c = (read-char stream eof-error-p nil) + while (and c (not (eql c #\return))) + do + (unless (eql c #\newline) + (write-char c s)) + finally + (return + (if empty nil (get-output-stream-string s)))))) + +(defun test-nntps-client (&optional (host "snews.gmane.org") (port 563)) + (let* ((fd (trivial-sockets:open-stream host port + :element-type '(unsigned-byte 8))) + (nntps (cl+ssl:make-ssl-client-stream fd))) + (format t "NNTPS> ~A~%" (read-line-crlf nntps)) + (write-line "HELP" nntps) + (force-output nntps) + (loop :for line = (read-line-crlf nntps nil) + :until (string-equal "." line) + :do (format t "NNTPS> ~A~%" line)))) + + +;; open an HTTPS connection to a secure web server and make a +;; HEAD request +(defun test-https-client (host &optional (port 443)) + (let* ((fd (trivial-sockets:open-stream host port + :element-type '(unsigned-byte 8))) + (https (cl+ssl:make-ssl-client-stream fd))) + (unwind-protect + (progn + (format https "HEAD / HTTP/1.0~%Host: ~a~%~%" host) + (force-output https) + (loop :for line = (read-line-crlf https nil) + :while line :do + (format t "HTTPS> ~a~%" line))) + (close https)))) + +;; start a simple HTTPS server. See the mod_ssl documentation at +;; for information on generating the +;; server certificate and key +;; +;; You can stress-test the server with +;; +;; siege -c 10 -u https://host:8080/foobar +;; +(defun test-https-server + (&key (port 8080) + (cert "/home/david/newcert.pem") + (key "/home/david/newkey.pem")) + (format t "~&SSL server listening on port ~d~%" port) + (trivial-sockets:with-server (server (:port port)) + (loop + (let ((client (cl+ssl:make-ssl-server-stream + (trivial-sockets:accept-connection + server + :element-type '(unsigned-byte 8)) + :certificate cert + :key key))) + (unwind-protect + (progn + (loop :for line = (read-line-crlf client nil) + :while (> (length line) 1) :do + (format t "HTTPS> ~a~%" line)) + (format client "HTTP/1.0 200 OK~%") + (format client "Server: SSL-CMUCL/1.1~%") + (format client "Content-Type: text/plain~%") + (terpri client) + (format client "G'day at ~A!~%" + (multiple-value-list (get-decoded-time))) + (format client "CL+SSL running in ~A ~A~%" + (lisp-implementation-type) + (lisp-implementation-version))) + (close client))))))