304 lines
11 KiB
Common Lisp
304 lines
11 KiB
Common Lisp
;;; Copyright (C) 2001, 2003 Eric Marsden
|
|
;;; Copyright (C) 2005 David Lichteblau
|
|
;;; Copyright (C) 2007 Pixel // pinterface
|
|
;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
|
|
;;;
|
|
;;; See LICENSE for details.
|
|
|
|
#+xcvb
|
|
(module
|
|
(:depends-on ("package" "conditions" "ffi"
|
|
(:cond ((:featurep :clisp) "ffi-buffer-clisp")
|
|
(t "ffi-buffer")))))
|
|
|
|
(eval-when (:compile-toplevel)
|
|
(declaim
|
|
(optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0))))
|
|
|
|
(in-package :cl+ssl)
|
|
|
|
(defclass ssl-stream
|
|
(fundamental-binary-input-stream
|
|
fundamental-binary-output-stream
|
|
trivial-gray-stream-mixin)
|
|
((ssl-stream-socket
|
|
:initarg :socket
|
|
:accessor ssl-stream-socket)
|
|
(close-callback
|
|
:initarg :close-callback
|
|
:accessor ssl-close-callback)
|
|
(handle
|
|
:initform nil
|
|
:accessor ssl-stream-handle)
|
|
(deadline
|
|
:initform nil
|
|
:initarg :deadline
|
|
:accessor ssl-stream-deadline)
|
|
(output-buffer
|
|
:initform (make-buffer +initial-buffer-size+)
|
|
:accessor ssl-stream-output-buffer)
|
|
(output-pointer
|
|
:initform 0
|
|
:accessor ssl-stream-output-pointer)
|
|
(input-buffer
|
|
:initform (make-buffer +initial-buffer-size+)
|
|
:accessor ssl-stream-input-buffer)
|
|
(peeked-byte
|
|
:initform nil
|
|
:accessor ssl-stream-peeked-byte)))
|
|
|
|
(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)))
|
|
|
|
(defmethod stream-element-type ((stream ssl-stream))
|
|
'(unsigned-byte 8))
|
|
|
|
(defmethod close ((stream ssl-stream) &key abort)
|
|
(cond
|
|
((ssl-stream-handle stream)
|
|
(unless abort
|
|
(force-output stream))
|
|
(ssl-free (ssl-stream-handle stream))
|
|
(setf (ssl-stream-handle stream) nil)
|
|
(when (streamp (ssl-stream-socket stream))
|
|
(close (ssl-stream-socket stream)))
|
|
(when (functionp (ssl-close-callback stream))
|
|
(funcall (ssl-close-callback stream)))
|
|
t)
|
|
(t
|
|
nil)))
|
|
|
|
(defmethod open-stream-p ((stream ssl-stream))
|
|
(and (ssl-stream-handle stream) t))
|
|
|
|
(defmethod stream-listen ((stream ssl-stream))
|
|
(or (ssl-stream-peeked-byte stream)
|
|
(setf (ssl-stream-peeked-byte stream)
|
|
(let* ((*blockp* nil)
|
|
(b (stream-read-byte stream)))
|
|
(if (eql b :eof) nil b)))))
|
|
|
|
(defmethod stream-read-byte ((stream ssl-stream))
|
|
(or (ssl-stream-peeked-byte stream)
|
|
(let ((buf (ssl-stream-input-buffer stream)))
|
|
(handler-case
|
|
(with-pointer-to-vector-data (ptr buf)
|
|
(ensure-ssl-funcall stream
|
|
(ssl-stream-handle stream)
|
|
#'ssl-read
|
|
(ssl-stream-handle stream)
|
|
ptr
|
|
1)
|
|
(buffer-elt buf 0))
|
|
(ssl-error-zero-return () ;SSL_read returns 0 on end-of-file
|
|
:eof)))))
|
|
|
|
(defmethod stream-read-sequence ((stream ssl-stream) thing start end &key)
|
|
(check-type thing (simple-array (unsigned-byte 8) (*)))
|
|
(when (and (< start end) (ssl-stream-peeked-byte stream))
|
|
(setf (elt thing start) (ssl-stream-peeked-byte stream))
|
|
(setf (ssl-stream-peeked-byte stream) nil)
|
|
(incf start))
|
|
(let ((buf (ssl-stream-input-buffer stream)))
|
|
(loop
|
|
for length = (min (- end start) (buffer-length buf))
|
|
while (plusp length)
|
|
do
|
|
(handler-case
|
|
(with-pointer-to-vector-data (ptr buf)
|
|
(ensure-ssl-funcall stream
|
|
(ssl-stream-handle stream)
|
|
#'ssl-read
|
|
(ssl-stream-handle stream)
|
|
ptr
|
|
length)
|
|
(v/b-replace thing buf :start1 start :end1 (+ start length))
|
|
(incf start length))
|
|
(ssl-error-zero-return () ;SSL_read returns 0 on end-of-file
|
|
(return))))
|
|
;; fixme: kein out-of-file wenn (zerop start)?
|
|
start))
|
|
|
|
(defmethod stream-write-byte ((stream ssl-stream) b)
|
|
(let ((buf (ssl-stream-output-buffer stream)))
|
|
(when (eql (buffer-length buf) (ssl-stream-output-pointer stream))
|
|
(force-output stream))
|
|
(setf (buffer-elt buf (ssl-stream-output-pointer stream)) b)
|
|
(incf (ssl-stream-output-pointer stream)))
|
|
b)
|
|
|
|
(defmethod stream-write-sequence ((stream ssl-stream) thing start end &key)
|
|
(check-type thing (simple-array (unsigned-byte 8) (*)))
|
|
(let ((buf (ssl-stream-output-buffer stream)))
|
|
(when (> (+ (- end start) (ssl-stream-output-pointer stream)) (buffer-length buf))
|
|
;; not enough space left? flush buffer.
|
|
(force-output stream)
|
|
;; still doesn't fit?
|
|
(while (> (- end start) (buffer-length buf))
|
|
(b/v-replace buf thing :start2 start)
|
|
(incf start (buffer-length buf))
|
|
(setf (ssl-stream-output-pointer stream) (buffer-length buf))
|
|
(force-output stream)))
|
|
(b/v-replace buf thing
|
|
:start1 (ssl-stream-output-pointer stream)
|
|
:start2 start
|
|
:end2 end)
|
|
(incf (ssl-stream-output-pointer stream) (- end start)))
|
|
thing)
|
|
|
|
(defmethod stream-finish-output ((stream ssl-stream))
|
|
(stream-force-output stream))
|
|
|
|
(defmethod stream-force-output ((stream ssl-stream))
|
|
(let ((buf (ssl-stream-output-buffer stream))
|
|
(fill-ptr (ssl-stream-output-pointer stream))
|
|
(handle (ssl-stream-handle stream)))
|
|
(when (plusp fill-ptr)
|
|
(unless handle
|
|
(error "output operation on closed SSL stream"))
|
|
(with-pointer-to-vector-data (ptr buf)
|
|
(ensure-ssl-funcall stream handle #'ssl-write handle ptr fill-ptr))
|
|
(setf (ssl-stream-output-pointer stream) 0))))
|
|
|
|
#+(and clozure-common-lisp (not windows))
|
|
(defun install-nonblock-flag (fd)
|
|
(ccl::fd-set-flags fd (logior (ccl::fd-get-flags fd)
|
|
#.(read-from-string "#$O_NONBLOCK"))))
|
|
;; read-from-string is necessary because
|
|
;; CLISP and perhaps other Lisps are confused
|
|
;; by #$, signaling"undefined dispatch character $",
|
|
;; even though the defun in conditionalized by
|
|
;; #+clozure-common-lisp
|
|
|
|
#+(and sbcl (not win32))
|
|
(defun install-nonblock-flag (fd)
|
|
(sb-posix:fcntl fd
|
|
sb-posix::f-setfl
|
|
(logior (sb-posix:fcntl fd sb-posix::f-getfl)
|
|
sb-posix::o-nonblock)))
|
|
|
|
#-(or (and clozure-common-lisp (not windows)) (and sbcl (not win32)))
|
|
(defun install-nonblock-flag (fd)
|
|
(declare (ignore fd)))
|
|
|
|
|
|
;;; interface functions
|
|
;;;
|
|
|
|
(defun install-handle-and-bio (stream handle socket unwrap-stream-p)
|
|
(setf (ssl-stream-handle stream) handle)
|
|
(when unwrap-stream-p
|
|
(let ((fd (stream-fd socket)))
|
|
(when fd
|
|
(setf socket fd))))
|
|
(etypecase socket
|
|
(integer
|
|
(install-nonblock-flag socket)
|
|
(ssl-set-fd handle socket))
|
|
(stream
|
|
(ssl-set-bio handle (bio-new-lisp) (bio-new-lisp))))
|
|
(ssl-ctx-ctrl handle
|
|
+SSL_CTRL_MODE+
|
|
+SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+
|
|
0)
|
|
socket)
|
|
|
|
(defun install-key-and-cert (handle key certificate)
|
|
(when key
|
|
(unless (eql 1 (ssl-use-rsa-privatekey-file handle
|
|
key
|
|
+ssl-filetype-pem+))
|
|
(error 'ssl-error-initialize :reason (format nil "Can't load RSA private key file ~A" key))))
|
|
(when certificate
|
|
(unless (eql 1 (ssl-use-certificate-file handle
|
|
certificate
|
|
+ssl-filetype-pem+))
|
|
(error 'ssl-error-initialize
|
|
:reason (format nil "Can't load certificate ~A" certificate)))))
|
|
|
|
(defun handle-external-format (stream ef)
|
|
(if ef
|
|
(flexi-streams:make-flexi-stream stream :external-format ef)
|
|
stream))
|
|
|
|
;; fixme: free the context when errors happen in this function
|
|
(defun make-ssl-client-stream
|
|
(socket &key certificate key password (method 'ssl-v23-method) external-format
|
|
close-callback (unwrap-stream-p t))
|
|
"Returns an SSL stream for the client socket descriptor SOCKET.
|
|
CERTIFICATE is the path to a file containing the PEM-encoded certificate for
|
|
your client. KEY is the path to the PEM-encoded key for the client, which
|
|
may be associated with the passphrase PASSWORD."
|
|
(ensure-initialized :method method)
|
|
(let ((stream (make-instance 'ssl-stream
|
|
:socket socket
|
|
:close-callback close-callback))
|
|
(handle (ssl-new *ssl-global-context*)))
|
|
(setf socket (install-handle-and-bio stream handle socket unwrap-stream-p))
|
|
(ssl-set-connect-state handle)
|
|
(with-pem-password (password)
|
|
(install-key-and-cert handle key certificate))
|
|
(ensure-ssl-funcall stream handle #'ssl-connect handle)
|
|
(handle-external-format stream external-format)))
|
|
|
|
;; fixme: free the context when errors happen in this function
|
|
(defun make-ssl-server-stream
|
|
(socket &key certificate key password (method 'ssl-v23-method) external-format
|
|
close-callback (unwrap-stream-p t))
|
|
"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
|
|
may be associated with the passphrase PASSWORD."
|
|
(ensure-initialized :method method)
|
|
(let ((stream (make-instance 'ssl-server-stream
|
|
:socket socket
|
|
:close-callback close-callback
|
|
:certificate certificate
|
|
:key key))
|
|
(handle (ssl-new *ssl-global-context*)))
|
|
(setf socket (install-handle-and-bio stream handle socket unwrap-stream-p))
|
|
(ssl-set-accept-state handle)
|
|
(when (zerop (ssl-set-cipher-list handle "ALL"))
|
|
(error 'ssl-error-initialize :reason "Can't set SSL cipher list"))
|
|
(with-pem-password (password)
|
|
(install-key-and-cert handle key certificate))
|
|
(ensure-ssl-funcall stream handle #'ssl-accept handle)
|
|
(handle-external-format stream external-format)))
|
|
|
|
#+openmcl
|
|
(defmethod stream-deadline ((stream ccl::basic-stream))
|
|
(ccl::ioblock-deadline (ccl::stream-ioblock stream t)))
|
|
#+openmcl
|
|
(defmethod stream-deadline ((stream t))
|
|
nil)
|
|
|
|
|
|
(defgeneric stream-fd (stream))
|
|
(defmethod stream-fd (stream) stream)
|
|
|
|
#+sbcl
|
|
(defmethod stream-fd ((stream sb-sys:fd-stream))
|
|
(sb-sys:fd-stream-fd stream))
|
|
|
|
#+cmu
|
|
(defmethod stream-fd ((stream system:fd-stream))
|
|
(system:fd-stream-fd stream))
|
|
|
|
#+openmcl
|
|
(defmethod stream-fd ((stream ccl::basic-stream))
|
|
(ccl::ioblock-device (ccl::stream-ioblock stream t)))
|
|
|
|
#+clisp
|
|
(defmethod stream-fd ((stream stream))
|
|
;; sockets appear to be direct instances of STREAM
|
|
(ignore-errors (socket:stream-handles stream)))
|