Initial revision
dlichteblau
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