Initial revision
commit
343a215d31
|
@ -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.
|
|
@ -0,0 +1,3 @@
|
||||||
|
.PHONY: clean
|
||||||
|
clean:
|
||||||
|
rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl
|
|
@ -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
|
|
@ -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")))
|
|
@ -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))))
|
|
@ -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))))
|
|
@ -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;
|
||||||
|
}
|
|
@ -0,0 +1,199 @@
|
||||||
|
<?xml version="1.0" encoding="iso-8859-1"?>
|
||||||
|
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
|
||||||
|
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
|
||||||
|
<head>
|
||||||
|
<title>CL+SSL</title>
|
||||||
|
<link rel="stylesheet" type="text/css" href="index.css"/>
|
||||||
|
</head>
|
||||||
|
<body>
|
||||||
|
<h1>CL<em style="font-weight: normal">plus</em>SSL</h1>
|
||||||
|
|
||||||
|
<h3>Subprojects</h3>
|
||||||
|
<ul>
|
||||||
|
<li><a href="#cl+ssl">CL+SSL</a></li>
|
||||||
|
<li><a href="#trivial-https">trivial-https</a></li>
|
||||||
|
<li><a href="#trivial-gray-streams">trivial-gray-streams</a></li>
|
||||||
|
</ul>
|
||||||
|
|
||||||
|
<h3>Download</h3>
|
||||||
|
<pre>$ 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</pre>
|
||||||
|
<p>
|
||||||
|
Note that you need the <tt>libssl-dev</tt> package on Debian to
|
||||||
|
load this package without manual configuration.
|
||||||
|
</p>
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Send bug reports to <a
|
||||||
|
href="mailto:cl-plus-ssl-devel@common-lisp.net">cl-plus-ssl-devel@common-lisp.net</a>
|
||||||
|
(<a
|
||||||
|
href="http://common-lisp.net/cgi-bin/mailman/listinfo/cl-plus-ssl-devel">list
|
||||||
|
information</a>)
|
||||||
|
or <a href="mailto:david@lichteblau.com">David Lichteblau</a>.
|
||||||
|
</p>
|
||||||
|
|
||||||
|
<a name="cl+ssl">
|
||||||
|
<h2>CL+SSL</h2>
|
||||||
|
|
||||||
|
<p>A simple Common Lisp interface to OpenSSL.</p>
|
||||||
|
|
||||||
|
<h3>About</h3>
|
||||||
|
|
||||||
|
<p>
|
||||||
|
This library is a fork of <a
|
||||||
|
href="http://www.cliki.net/SSL-CMUCL">SSL-CMUCL</a>. The original
|
||||||
|
SSL-CMUCL source code was written by Eric Marsden and includes
|
||||||
|
contributions by Jochen Schmidt. License: LGPL.
|
||||||
|
</p>
|
||||||
|
|
||||||
|
<ul>
|
||||||
|
<li>
|
||||||
|
CL+SSL is portable code based on CFFI and gray streams.
|
||||||
|
</li>
|
||||||
|
<li>
|
||||||
|
It defines its own libssl BIO method, so that SSL I/O is
|
||||||
|
actually written over portable Lisp streams instead of bypassing
|
||||||
|
the streams and sending data over Unix file descriptors directly.
|
||||||
|
</li>
|
||||||
|
</ul>
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Comparison chart:
|
||||||
|
</p>
|
||||||
|
<table border="1" cellpadding="2" cellspacing="0">
|
||||||
|
<thead>
|
||||||
|
<tr>
|
||||||
|
<th></th>
|
||||||
|
<th><b>FFI</b></th>
|
||||||
|
<th><b>Streams</b></th>
|
||||||
|
<th><b>Lisp-BIO</b></th>
|
||||||
|
</tr>
|
||||||
|
</thead>
|
||||||
|
<tr>
|
||||||
|
<td>CL+SSL</td>
|
||||||
|
<td>CFFI</td>
|
||||||
|
<td>gray, non-buffering</td>
|
||||||
|
<td>yes</td>
|
||||||
|
</tr>
|
||||||
|
<tr>
|
||||||
|
<td>CL-SSL</td>
|
||||||
|
<td>UFFI</td>
|
||||||
|
<td>gray, buffering [<em>part of ACL-COMPAT</em>]</td>
|
||||||
|
<td>no</td>
|
||||||
|
</tr>
|
||||||
|
<tr>
|
||||||
|
<td>SSL-CMUCL</td>
|
||||||
|
<td>CMUCL/ALIEN</td>
|
||||||
|
<td>CMUCL, non-buffering</td>
|
||||||
|
<td>no</td>
|
||||||
|
</tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<h3>API functions</h3>
|
||||||
|
<p>
|
||||||
|
<div class="def">Variable CL+SSL-SYSTEM:*LIBSSL-PATHNAME*</div>
|
||||||
|
Full pathname of the SSL library. Defaults
|
||||||
|
to <tt>/usr/lib/libssl.so</tt>. If the default is not correct for
|
||||||
|
your system, set this variable between loading the .asd file and
|
||||||
|
load-op'ing the system.
|
||||||
|
</p>
|
||||||
|
<p>
|
||||||
|
<div class="def">Function CL+SSL:MAKE-SSL-CLIENT-STREAM (stream)</div>
|
||||||
|
Return an SSL stream for the client socket <tt>stream</tt>.
|
||||||
|
All reads and writes to this SSL stream will be pushed through the
|
||||||
|
SSL connection can be closed using the standard <tt>close</tt> function.
|
||||||
|
</p>
|
||||||
|
<p>
|
||||||
|
<div class="def">Function CL+SSL:MAKE-SSL-SERVER-STREAM (stream &key certificate key)</div>
|
||||||
|
Return an SSL stream for the server socket <tt>stream</tt>. All
|
||||||
|
reads and writes to this server stream will be pushed through the
|
||||||
|
OpenSSL library. The SSL connection can be closed using the
|
||||||
|
standard <tt>close</tt> function.
|
||||||
|
</p>
|
||||||
|
<p>
|
||||||
|
<tt>certificate</tt> is the path to a file containing the PEM-encoded
|
||||||
|
certificate for your server. <tt>key</tt> is the path to the PEM-encoded
|
||||||
|
key for the server, which must not be associated with a
|
||||||
|
passphrase.
|
||||||
|
</p>
|
||||||
|
|
||||||
|
<h3>Portability</h3>
|
||||||
|
<p>
|
||||||
|
CL+SSL requires CFFI with callback support.
|
||||||
|
</p>
|
||||||
|
<p>
|
||||||
|
Test results for Linux/x86, except OpenMCL which was tested on
|
||||||
|
Linux/PPC:
|
||||||
|
</p>
|
||||||
|
<table border="1" cellpadding="2" cellspacing="0">
|
||||||
|
<thead>
|
||||||
|
<tr>
|
||||||
|
<th><b>Lisp Implementation</b></th>
|
||||||
|
<th><b>Status</b></th>
|
||||||
|
<th><b>Comments</b></th>
|
||||||
|
</tr>
|
||||||
|
</thead>
|
||||||
|
<tr><td>OpenMCL</td><td class="working">Working</td></tr>
|
||||||
|
<tr><td>SBCL</td><td class="working">Working</td></tr>
|
||||||
|
<tr><td>CMU CL</td><td class="working">Working</td></tr>
|
||||||
|
<tr>
|
||||||
|
<td>CLISP</td>
|
||||||
|
<td class="incomplete">Working</td>
|
||||||
|
<td>Extremely slow?</td>
|
||||||
|
</tr>
|
||||||
|
<tr><td>LispWorks</td><td class="working">Working</td></tr>
|
||||||
|
<tr>
|
||||||
|
<td>Allegro</td>
|
||||||
|
<td class="broken">Broken</td>
|
||||||
|
<td>segfault</td>
|
||||||
|
</tr>
|
||||||
|
<tr><td>Corman CL</td><td class="unknown">Unknown</td></tr>
|
||||||
|
<tr><td>Digitool MCL</td><td class="unknown">Unknown</td></tr>
|
||||||
|
<tr><td>Scieneer CL</td><td class="unknown">Unknown</td></tr>
|
||||||
|
<tr><td>ECL</td><td class="unknown">Unknown</td></tr>
|
||||||
|
<tr><td>GCL</td><td class="unknown">Unknown</td></tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<h3>TODO</h3>
|
||||||
|
<ul>
|
||||||
|
<li>Profile and optimize if needed. (CLISP?)</li>
|
||||||
|
<li>Implement remaining gray streams methods.</li>
|
||||||
|
<li>Add external format support on Unicode-capable Lisps.</li>
|
||||||
|
</ul>
|
||||||
|
<h3>Maybe</h3>
|
||||||
|
<ul>
|
||||||
|
<li>Add buffering to gray streams layer?</li>
|
||||||
|
<li>Add simple-streams layer instead of gray streams?</li>
|
||||||
|
</ul>
|
||||||
|
|
||||||
|
<a name="trivial-https">
|
||||||
|
<h2>trivial-https</h2>
|
||||||
|
|
||||||
|
<p>
|
||||||
|
trivial-https is a fork of Brian
|
||||||
|
Mastenbrook's <a
|
||||||
|
href="http://www.cliki.net/trivial-http">trivial-http</a> adding
|
||||||
|
support for HTTPS using CL+SSL.
|
||||||
|
</p>
|
||||||
|
|
||||||
|
<p>
|
||||||
|
<a href="">README</a>
|
||||||
|
</p>
|
||||||
|
|
||||||
|
<a name="trivial-gray-streams">
|
||||||
|
<h2>trivial-gray-streams</h2>
|
||||||
|
|
||||||
|
<p>
|
||||||
|
trivial-gray-streams provides an extremely thin compatibility
|
||||||
|
layer for gray streams.
|
||||||
|
</p>
|
||||||
|
|
||||||
|
<p>
|
||||||
|
<a href="">README</a>
|
||||||
|
</p>
|
||||||
|
</body>
|
||||||
|
</html>
|
|
@ -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))
|
|
@ -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*)
|
|
@ -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))
|
|
@ -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
|
||||||
|
;; <URL:http://www.modssl.org/> 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))))))
|
Loading…
Reference in New Issue