├── README ├── index.html ├── Makefile ├── ffi-buffer-all.lisp ├── ffi-buffer.lisp ├── package.lisp ├── cl+ssl.asd ├── index.css ├── LICENSE ├── random.lisp ├── ffi-buffer-clisp.lisp ├── reload.lisp ├── todo.txt ├── example.lisp ├── bio.lisp ├── ssl-verify-test.lisp ├── test.lisp ├── conditions.lisp ├── streams.lisp └── ffi.lisp /README: -------------------------------------------------------------------------------- 1 | See project homepage: http://common-lisp.net/project/cl-plus-ssl/ -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruricolist/cl-plus-ssl/master/index.html -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: clean 2 | clean: 3 | rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl 4 | -------------------------------------------------------------------------------- /ffi-buffer-all.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module (:depends-on ("package"))) 2 | 3 | (in-package :cl+ssl) 4 | 5 | (defconstant +initial-buffer-size+ 2048) 6 | 7 | (declaim 8 | (inline 9 | make-buffer 10 | buffer-length 11 | buffer-elt 12 | set-buffer-elt 13 | s/b-replace 14 | b/s-replace)) 15 | -------------------------------------------------------------------------------- /ffi-buffer.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module (:depends-on ("package"))) 2 | 3 | (in-package :cl+ssl) 4 | 5 | (defun make-buffer (size) 6 | (cffi-sys::make-shareable-byte-vector size)) 7 | 8 | (defun buffer-length (buf) 9 | (length buf)) 10 | 11 | (defun buffer-elt (buf index) 12 | (elt buf index)) 13 | (defun set-buffer-elt (buf index val) 14 | (setf (elt buf index) val)) 15 | (defsetf buffer-elt set-buffer-elt) 16 | 17 | (defun s/b-replace (seq buf &key (start1 0) end1 (start2 0) end2) 18 | (replace seq buf :start1 start1 :end1 end1 :start2 start2 :end2 end2)) 19 | (defun b/s-replace (buf seq &key (start1 0) end1 (start2 0) end2) 20 | (replace buf seq :start1 start1 :end1 end1 :start2 start2 :end2 end2)) 21 | 22 | (defmacro with-pointer-to-vector-data ((ptr buf) &body body) 23 | `(cffi-sys::with-pointer-to-vector-data (,ptr ,buf) 24 | ,@body)) 25 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2001, 2003 Eric Marsden 2 | ;;; Copyright (C) 2005 David Lichteblau 3 | ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." 4 | ;;; 5 | ;;; See LICENSE for details. 6 | 7 | #+xcvb (module (:depends-on ((:when (:featurep :sbcl) (:require :sb-posix))))) 8 | 9 | (in-package :cl-user) 10 | 11 | (defpackage :cl+ssl 12 | (:use :common-lisp :trivial-gray-streams) 13 | (:export #:*default-cipher-list* 14 | #:ensure-initialized 15 | #:reload 16 | #:stream-fd 17 | #:make-ssl-client-stream 18 | #:make-ssl-server-stream 19 | #:use-certificate-chain-file 20 | #:random-bytes 21 | #:ssl-check-verify-p 22 | #:ssl-load-global-verify-locations 23 | #:ssl-set-global-default-verify-paths 24 | #:ssl-error-verify 25 | #:ssl-error-stream 26 | #:ssl-error-code)) 27 | -------------------------------------------------------------------------------- /cl+ssl.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: lisp -*- 2 | ;;; 3 | ;;; Copyright (C) 2001, 2003 Eric Marsden 4 | ;;; Copyright (C) 2005 David Lichteblau 5 | ;;; Copyright (C) 2007 Pixel // pinterface 6 | ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." 7 | ;;; 8 | ;;; See LICENSE for details. 9 | 10 | (defpackage :cl+ssl-system 11 | (:use :cl :asdf)) 12 | 13 | (in-package :cl+ssl-system) 14 | 15 | (defsystem :cl+ssl 16 | :description "Common Lisp interface to OpenSSL." 17 | :license "MIT" 18 | :author "Eric Marsden, Jochen Schmidt, David Lichteblau" 19 | :depends-on (:cffi :trivial-gray-streams :flexi-streams #+sbcl :sb-posix 20 | :bordeaux-threads :trivial-garbage) 21 | :serial t 22 | :components 23 | ((:file "package") 24 | (:file "reload") 25 | (:file "conditions") 26 | (:file "ffi") 27 | (:file "ffi-buffer-all") 28 | #-clisp (:file "ffi-buffer") 29 | #+clisp (:file "ffi-buffer-clisp") 30 | (:file "streams") 31 | (:file "bio") 32 | (:file "random"))) 33 | -------------------------------------------------------------------------------- /index.css: -------------------------------------------------------------------------------- 1 | div.sidebar { 2 | float: right; 3 | background-color: #eeeeee; 4 | border: 2pt solid black; 5 | margin: 0em 2pt 1em 2em; 6 | min-width: 15%; 7 | padding: 0pt 5pt 5pt 5pt; 8 | } 9 | 10 | div.sidebar ul { 11 | padding: 0pt 0pt 0pt 1em; 12 | margin: 0 0 1em; 13 | } 14 | 15 | body { 16 | color: #000000; 17 | background-color: #ffffff; 18 | margin-right: 0pt; 19 | margin-bottom: 10%; 20 | padding-left: 30px; 21 | } 22 | 23 | h1,h2 { 24 | margin-left: -30px; 25 | } 26 | 27 | h3 { 28 | margin-top: 2em; 29 | margin-left: -20px; 30 | } 31 | 32 | th { 33 | background-color: darkred; 34 | color: white; 35 | text-align: left; 36 | } 37 | 38 | pre { 39 | background-color: #eeeeee; 40 | border: solid 1px #d0d0d0; 41 | padding: 1em; 42 | margin-right: 10%; 43 | } 44 | 45 | .def { 46 | background-color: #eeeeee; 47 | width: 90%; 48 | font-weight: bold; 49 | border: solid 1px #d0d0d0; 50 | padding: 3px; 51 | } 52 | 53 | .nomargin { 54 | margin-bottom: 0; 55 | margin-top: 0; 56 | } 57 | 58 | .working { 59 | background-color: #60c060; 60 | } 61 | 62 | .broken { 63 | background-color: #ff6060; 64 | } 65 | 66 | .incomplete { 67 | background-color: #ffff60; 68 | } 69 | 70 | .unknown { 71 | background-color: #cccccc; 72 | } 73 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2001, 2003 Eric Marsden 2 | Copyright (C) ???? Jochen Schmidt 3 | Copyright (C) 2005 David Lichteblau 4 | Copyright (C) 2007 Pixel // pinterface 5 | 6 | * License first changed by Eric Marsden, Jochen Schmidt, and David Lichteblau 7 | from plain LGPL to Lisp-LGPL in December 2005. 8 | 9 | * License then changed by Eric Marsden, Jochen Schmidt, and David Lichteblau 10 | from Lisp-LGPL to MIT-style in January 2007. 11 | 12 | 13 | Permission is hereby granted, free of charge, to any person 14 | obtaining a copy of this software and associated documentation files 15 | (the "Software"), to deal in the Software without restriction, 16 | including without limitation the rights to use, copy, modify, merge, 17 | publish, distribute, sublicense, and/or sell copies of the Software, 18 | and to permit persons to whom the Software is furnished to do so, 19 | subject to the following conditions: 20 | 21 | The above copyright notice and this permission notice shall be 22 | included in all copies or substantial portions of the Software. 23 | 24 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 25 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 26 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 27 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 28 | BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 29 | ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 30 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 31 | SOFTWARE. 32 | -------------------------------------------------------------------------------- /random.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb 2 | (module 3 | (:depends-on ("package" "conditions" "ffi" 4 | (:cond ((:featurep :clisp) "ffi-buffer-clisp") 5 | (t "ffi-buffer")) 6 | "ffi-buffer-all"))) 7 | 8 | (in-package :cl+ssl) 9 | 10 | (defun random-bytes (count) 11 | "Generates COUNT cryptographically strong pseudo-random bytes. Returns 12 | the bytes as a SIMPLE-ARRAY with ELEMENT-TYPE '(UNSIGNED-BYTE 8). Signals 13 | an ERROR in case of problems, for example when the OpenSSL random number 14 | generator has not been seeded with enough randomness to ensure an 15 | unpredictable byte sequence." 16 | (let* ((result (make-array count :element-type '(unsigned-byte 8))) 17 | (buf (make-buffer count)) 18 | (ret (with-pointer-to-vector-data (ptr buf) 19 | (rand-bytes ptr count)))) 20 | (when (/= 1 ret) 21 | (error "RANDOM-BYTES failed: error reported by the OpenSSL RAND_bytes function. ~A." 22 | (format-ssl-error-queue nil (read-ssl-error-queue)))) 23 | (s/b-replace result buf))) 24 | 25 | ;; TODO: Should we define random-specific constants and condition classes for 26 | ;; RAND_F_RAND_GET_RAND_METHOD, RAND_F_SSLEAY_RAND_BYTES, RAND_R_PRNG_NOT_SEEDED 27 | ;; (defined in the rand.h file of the OpenSSl sources)? 28 | ;; Where to place these constants/condtitions, here or in the conditions.lisp? 29 | ;; On the other hand, those constants are just numbers defined for C, 30 | ;; for now we jsut report human readable strings, without possibility 31 | ;; to distinguish these error causes programmatically. 32 | 33 | -------------------------------------------------------------------------------- /ffi-buffer-clisp.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module (:depends-on ("package" "reload" "conditions" "ffi" "ffi-buffer-all"))) 2 | 3 | (in-package :cl+ssl) 4 | 5 | (defun make-buffer (size) 6 | (cffi-sys:%foreign-alloc size)) 7 | 8 | (defun buffer-length (buf) 9 | (declare (ignore buf)) 10 | +initial-buffer-size+) 11 | 12 | (defun buffer-elt (buf index) 13 | (ffi:memory-as buf 'ffi:uint8 index)) 14 | (defun set-buffer-elt (buf index val) 15 | (setf (ffi:memory-as buf 'ffi:uint8 index) val)) 16 | (defsetf buffer-elt set-buffer-elt) 17 | 18 | (declaim 19 | (inline calc-buf-end)) 20 | 21 | ;; to calculate non NIL value of the buffer end index 22 | (defun calc-buf-end (buf-start seq seq-start seq-end) 23 | (+ buf-start 24 | (- (or seq-end (length seq)) 25 | seq-start))) 26 | 27 | (defun s/b-replace (seq buf &key (start1 0) end1 (start2 0) end2) 28 | (when (null end2) 29 | (setf end2 (calc-buf-end start2 seq start1 end1))) 30 | (replace 31 | seq 32 | (ffi:memory-as buf (ffi:parse-c-type `(ffi:c-array ffi:uint8 ,(- end2 start2))) start2) 33 | :start1 start1 34 | :end1 end1)) 35 | 36 | (defun as-vector (seq) 37 | (if (typep seq 'vector) 38 | seq 39 | (make-array (length seq) :initial-contents seq :element-type '(unsigned-byte 8)))) 40 | 41 | (defun b/s-replace (buf seq &key (start1 0) end1 (start2 0) end2) 42 | (when (null end1) 43 | (setf end1 (calc-buf-end start1 seq start2 end2))) 44 | (setf 45 | (ffi:memory-as buf (ffi:parse-c-type `(ffi:c-array ffi:uint8 ,(- end1 start1))) start1) 46 | (as-vector (subseq seq start2 end2))) 47 | seq) 48 | 49 | (defmacro with-pointer-to-vector-data ((ptr buf) &body body) 50 | `(let ((,ptr ,buf)) 51 | ,@body)) 52 | -------------------------------------------------------------------------------- /reload.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2001, 2003 Eric Marsden 2 | ;;; Copyright (C) 2005 David Lichteblau 3 | ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." 4 | ;;; 5 | ;;; See LICENSE for details. 6 | 7 | ;;; We do this in an extra file so that it happens 8 | ;;; - after the asd file has been loaded, so that users can 9 | ;;; customize *libssl-pathname* between loading the asd and LOAD-OPing 10 | ;;; the actual sources 11 | ;;; - before ssl.lisp is loaded, which needs the library at compilation 12 | ;;; time on some implemenations 13 | ;;; - but not every time ffi.lisp is re-loaded as would happen if we 14 | ;;; put this directly into ffi.lisp 15 | 16 | #+xcvb (module (:depends-on ("package"))) 17 | 18 | (in-package :cl+ssl) 19 | 20 | ;; OpenBSD needs to load libcrypto before libssl 21 | #+openbsd 22 | (progn 23 | (cffi:define-foreign-library libcrypto 24 | (:openbsd "libcrypto.so")) 25 | (cffi:use-foreign-library libcrypto)) 26 | 27 | (cffi:define-foreign-library libssl 28 | (:windows "libssl32.dll") 29 | (:darwin (:or "libssl.dylib" "/usr/lib/libssl.dylib")) 30 | (:solaris (:or "/lib/64/libssl.so" 31 | "libssl.so.0.9.8" "libssl.so" "libssl.so.4")) 32 | ;; Unlike some other systems, OpenBSD linker, 33 | ;; when passed library name without versions at the end, 34 | ;; will locate the library with highest macro.minor version, 35 | ;; so we can just use just "libssl.so". 36 | ;; More info at https://github.com/cl-plus-ssl/cl-plus-ssl/pull/2. 37 | (:openbsd "libssl.so") 38 | ((and :unix (not :cygwin)) (:or "libssl.so.1.0.0" 39 | "libssl.so.0.9.8" 40 | "libssl.so" 41 | "libssl.so.4")) 42 | (:cygwin "cygssl-1.0.0.dll") 43 | (t (:default "libssl3"))) 44 | 45 | (cffi:use-foreign-library libssl) 46 | 47 | (cffi:define-foreign-library libeay32 48 | (:windows "libeay32.dll")) 49 | 50 | (cffi:use-foreign-library libeay32) 51 | -------------------------------------------------------------------------------- /todo.txt: -------------------------------------------------------------------------------- 1 | - Fix the CCL crash. 2 | - Separate project page and a Git repo for trivial-gray-streams. 3 | - Remove the ENSURE-INITIALIZED function from the public API. 4 | It was only intoroduced to provide users access to the RAND-SEEND 5 | which we decided to pass as a parameter to the ENSURE-INITIALIZED. 6 | We did this because solaris users complained, as Solaris doesn't 7 | have /dev/random, /dev/urnandom files which OpenSSL uses to initialize 8 | it's random number generator. But now we know that on Solaris people can 9 | use EGD: The Entropy Gathering Daemon: http://egd.sourceforge.net/, 10 | and OpenSSL uses it if it's running on a systems without /dev/random. 11 | Therefore we should get rid of the ENSURE-INITIALIZED and just 12 | put an excerpt from the OpenSSL docs about what software should 13 | be installed on the systems without /dev/random. 14 | - The stream-fd function is confusing when it's called with ssl-stream as 15 | a parameter; a developer might think this function allows to retrieve a 16 | socket file descriptor from an ssl-strem, but this function is implemented 17 | only for "native" socket streams provided by the Lisp implementation. 18 | Makes sense to implement it for ssl-stream too. 19 | - The ssl-error-syscall condition uses (err-get-error) in it's :report 20 | function. This is not correct; (err-get-error) should be queried 21 | when the error occurs. The result might be stored in a slot of 22 | the ssl-error-syscall and printed by the :report function. 23 | - Fix LispBIO. 24 | - Extract the low-level SSL code into a separate library that supports 25 | both OpenSSL and GnuTLS (maybe into two thin FFI libraries). 26 | - Implement SSL in IOLib adding an API system that only defines stubs that 27 | signal an error, and adding implementation systems using the before 28 | mentioned thin FFI wrapper libraries. IOLib doesn't support windows, 29 | therefore with this plan we will either need to drop Windows support 30 | (at tleast for the IOLib based asynch subset of features), or 31 | implement Windows support in IOLib. -------------------------------------------------------------------------------- /example.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2001, 2003 Eric Marsden 2 | ;;; Copyright (C) 2005 David Lichteblau 3 | ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." 4 | ;;; 5 | ;;; See LICENSE for details. 6 | 7 | #| 8 | (load "example.lisp") 9 | (ssl-test::test-https-client "www.google.com") 10 | (ssl-test::test-https-server) 11 | |# 12 | 13 | (defpackage :ssl-test 14 | (:use :cl)) 15 | (in-package :ssl-test) 16 | 17 | (eval-when (:compile-toplevel :load-toplevel :execute) 18 | (asdf:operate 'asdf:load-op :trivial-sockets)) 19 | 20 | (defun read-line-crlf (stream &optional eof-error-p) 21 | (let ((s (make-string-output-stream))) 22 | (loop 23 | for empty = t then nil 24 | for c = (read-char stream eof-error-p nil) 25 | while (and c (not (eql c #\return))) 26 | do 27 | (unless (eql c #\newline) 28 | (write-char c s)) 29 | finally 30 | (return 31 | (if empty nil (get-output-stream-string s)))))) 32 | 33 | (defun test-nntps-client (&optional (host "snews.gmane.org") (port 563)) 34 | (let* ((fd (trivial-sockets:open-stream host port 35 | :element-type '(unsigned-byte 8))) 36 | (nntps (cl+ssl:make-ssl-client-stream fd :external-format '(:iso-8859-1 :eol-style :lf)))) 37 | (format t "NNTPS> ~A~%" (read-line-crlf nntps)) 38 | (write-line "HELP" nntps) 39 | (force-output nntps) 40 | (loop :for line = (read-line-crlf nntps nil) 41 | :until (string-equal "." line) 42 | :do (format t "NNTPS> ~A~%" line)))) 43 | 44 | 45 | ;; open an HTTPS connection to a secure web server and make a 46 | ;; HEAD request 47 | (defun test-https-client (host &optional (port 443)) 48 | (let* ((deadline (+ (get-internal-real-time) 49 | (* 3 internal-time-units-per-second))) 50 | (socket (ccl:make-socket :address-family :internet 51 | :connect :active 52 | :type :stream 53 | :remote-host host 54 | :remote-port port 55 | ;; :local-host (resolve-hostname local-host) 56 | ;; :local-port local-port 57 | :deadline deadline)) 58 | (https 59 | (progn 60 | (cl+ssl:make-ssl-client-stream 61 | socket 62 | :unwrap-stream-p t 63 | :external-format '(:iso-8859-1 :eol-style :lf))))) 64 | (unwind-protect 65 | (progn 66 | (format https "GET / HTTP/1.0~%Host: ~a~%~%" host) 67 | (force-output https) 68 | (loop :for line = (read-line-crlf https nil) 69 | :while line :do 70 | (format t "HTTPS> ~a~%" line))) 71 | (close https)))) 72 | 73 | ;; start a simple HTTPS server. See the mod_ssl documentation at 74 | ;; for information on generating the 75 | ;; server certificate and key 76 | ;; 77 | ;; You can stress-test the server with 78 | ;; 79 | ;; siege -c 10 -u https://host:8080/foobar 80 | ;; 81 | (defun test-https-server 82 | (&key (port 8080) 83 | (cert "/home/david/newcert.pem") 84 | (key "/home/david/newkey.pem")) 85 | (format t "~&SSL server listening on port ~d~%" port) 86 | (trivial-sockets:with-server (server (:port port)) 87 | (loop 88 | (let* ((socket (trivial-sockets:accept-connection 89 | server 90 | :element-type '(unsigned-byte 8))) 91 | (client (cl+ssl:make-ssl-server-stream 92 | socket 93 | :external-format '(:iso-8859-1 :eol-style :lf) 94 | :certificate cert 95 | :key key))) 96 | (unwind-protect 97 | (progn 98 | (loop :for line = (read-line-crlf client nil) 99 | :while (> (length line) 1) :do 100 | (format t "HTTPS> ~a~%" line)) 101 | (format client "HTTP/1.0 200 OK~%") 102 | (format client "Server: SSL-CMUCL/1.1~%") 103 | (format client "Content-Type: text/plain~%") 104 | (terpri client) 105 | (format client "G'day at ~A!~%" 106 | (multiple-value-list (get-decoded-time))) 107 | (format client "CL+SSL running in ~A ~A~%" 108 | (lisp-implementation-type) 109 | (lisp-implementation-version))) 110 | (close client)))))) 111 | -------------------------------------------------------------------------------- /bio.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2005 David Lichteblau 2 | ;;; 3 | ;;; See LICENSE for details. 4 | 5 | #+xcvb (module (:depends-on ("package"))) 6 | 7 | (in-package cl+ssl) 8 | 9 | (defconstant +bio-type-socket+ (logior 5 #x0400 #x0100)) 10 | (defconstant +BIO_FLAGS_READ+ 1) 11 | (defconstant +BIO_FLAGS_WRITE+ 2) 12 | (defconstant +BIO_FLAGS_SHOULD_RETRY+ 8) 13 | (defconstant +BIO_CTRL_FLUSH+ 11) 14 | 15 | (cffi:defcstruct bio-method 16 | (type :int) 17 | (name :pointer) 18 | (bwrite :pointer) 19 | (bread :pointer) 20 | (bputs :pointer) 21 | (bgets :pointer) 22 | (ctrl :pointer) 23 | (create :pointer) 24 | (destroy :pointer) 25 | (callback-ctrl :pointer)) 26 | 27 | (cffi:defcstruct bio 28 | (method :pointer) 29 | (callback :pointer) 30 | (cb-arg :pointer) 31 | (init :int) 32 | (shutdown :int) 33 | (flags :int) 34 | (retry-reason :int) 35 | (num :int) 36 | (ptr :pointer) 37 | (next-bio :pointer) 38 | (prev-bio :pointer) 39 | (references :int) 40 | (num-read :unsigned-long) 41 | (num-write :unsigned-long) 42 | (crypto-ex-data-stack :pointer) 43 | (crypto-ex-data-dummy :int)) 44 | 45 | (defun make-bio-lisp-method () 46 | (let ((m (cffi:foreign-alloc '(:struct bio-method)))) 47 | (setf (cffi:foreign-slot-value m '(:struct bio-method) 'type) 48 | ;; fixme: this is wrong, but presumably still better than some 49 | ;; random value here. 50 | +bio-type-socket+) 51 | (macrolet ((slot (name) 52 | `(cffi:foreign-slot-value m '(:struct bio-method) ,name))) 53 | (setf (slot 'name) (cffi:foreign-string-alloc "lisp")) 54 | (setf (slot 'bwrite) (cffi:callback lisp-write)) 55 | (setf (slot 'bread) (cffi:callback lisp-read)) 56 | (setf (slot 'bputs) (cffi:callback lisp-puts)) 57 | (setf (slot 'bgets) (cffi:null-pointer)) 58 | (setf (slot 'ctrl) (cffi:callback lisp-ctrl)) 59 | (setf (slot 'create) (cffi:callback lisp-create)) 60 | (setf (slot 'destroy) (cffi:callback lisp-destroy)) 61 | (setf (slot 'callback-ctrl) (cffi:null-pointer))) 62 | m)) 63 | 64 | (defun bio-new-lisp () 65 | (bio-new *bio-lisp-method*)) 66 | 67 | 68 | ;;; "cargo cult" 69 | 70 | (cffi:defcallback lisp-write :int ((bio :pointer) (buf :pointer) (n :int)) 71 | bio 72 | (dotimes (i n) 73 | (write-byte (cffi:mem-ref buf :unsigned-char i) *socket*)) 74 | (finish-output *socket*) 75 | n) 76 | 77 | (defun clear-retry-flags (bio) 78 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 79 | (logandc2 (cffi:foreign-slot-value bio '(:struct bio) 'flags) 80 | (logior +BIO_FLAGS_READ+ 81 | +BIO_FLAGS_WRITE+ 82 | +BIO_FLAGS_SHOULD_RETRY+)))) 83 | 84 | (defun set-retry-read (bio) 85 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 86 | (logior (cffi:foreign-slot-value bio '(:struct bio) 'flags) 87 | +BIO_FLAGS_READ+ 88 | +BIO_FLAGS_SHOULD_RETRY+))) 89 | 90 | (cffi:defcallback lisp-read :int ((bio :pointer) (buf :pointer) (n :int)) 91 | bio buf n 92 | (let ((i 0)) 93 | (handler-case 94 | (unless (or (cffi:null-pointer-p buf) (null n)) 95 | (clear-retry-flags bio) 96 | (when (or *blockp* (listen *socket*)) 97 | (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*)) 98 | (incf i)) 99 | (loop 100 | while (and (< i n) 101 | (or (null *partial-read-p*) (listen *socket*))) 102 | do 103 | (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*)) 104 | (incf i)) 105 | #+(or) 106 | (when (zerop i) (set-retry-read bio))) 107 | (end-of-file ())) 108 | i)) 109 | 110 | (cffi:defcallback lisp-puts :int ((bio :pointer) (buf :string)) 111 | bio buf 112 | (error "lisp-puts not implemented")) 113 | 114 | (cffi:defcallback lisp-ctrl :int 115 | ((bio :pointer) (cmd :int) (larg :long) (parg :pointer)) 116 | bio larg parg 117 | (cond 118 | ((eql cmd +BIO_CTRL_FLUSH+) 1) 119 | (t 120 | ;; (warn "lisp-ctrl(~A,~A,~A)" cmd larg parg) 121 | 0))) 122 | 123 | (cffi:defcallback lisp-create :int ((bio :pointer)) 124 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 1) 125 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'num) 0) 126 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'ptr) (cffi:null-pointer)) 127 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0) 128 | 1) 129 | 130 | (cffi:defcallback lisp-destroy :int ((bio :pointer)) 131 | (cond 132 | ((cffi:null-pointer-p bio) 0) 133 | (t 134 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 0) 135 | (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0) 136 | 1))) 137 | 138 | (setf *bio-lisp-method* nil) ;force reinit if anything changed here 139 | -------------------------------------------------------------------------------- /ssl-verify-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2011 David Lichteblau 2 | ;;; 3 | ;;; See LICENSE for details. 4 | 5 | #+xcvb (module (:depends-on ("package"))) 6 | 7 | (in-package :cl+ssl) 8 | 9 | ;; from cl+ssl/example.lisp 10 | (defun read-line-crlf-2 (stream &optional eof-error-p) 11 | (let ((s (make-string-output-stream))) 12 | (loop 13 | for empty = t then nil 14 | for c = (read-char stream eof-error-p nil) 15 | while (and c (not (eql c #\return))) 16 | do 17 | (unless (eql c #\newline) 18 | (write-char c s)) 19 | finally 20 | (return 21 | (if empty nil (get-output-stream-string s)))))) 22 | 23 | (defun write-ssl-certificate-names (ssl-stream &optional (output-stream t)) 24 | (let* ((ssl (ssl-stream-handle ssl-stream)) 25 | (cert (ssl-get-peer-certificate ssl))) 26 | (unless (cffi:null-pointer-p cert) 27 | (unwind-protect 28 | (multiple-value-bind (issuer subject) 29 | (x509-certificate-names cert) 30 | (format output-stream 31 | " issuer: ~a~% subject: ~a~%" issuer subject)) 32 | (x509-free cert))))) 33 | 34 | ;; from cl+ssl/example.lisp 35 | (defun test-https-client-2 (host &key (port 443) show-text-p) 36 | (let* ((deadline (+ (get-internal-real-time) 37 | (* 3 internal-time-units-per-second))) 38 | (socket (ccl:make-socket :address-family :internet 39 | :connect :active 40 | :type :stream 41 | :remote-host host 42 | :remote-port port 43 | ;; :local-host (resolve-hostname local-host) 44 | ;; :local-port local-port 45 | :deadline deadline)) 46 | https) 47 | (unwind-protect 48 | (handler-bind 49 | ((ssl-error-verify 50 | (lambda (c) 51 | (write-ssl-certificate-names (ssl-error-stream c))))) 52 | (setf https 53 | (cl+ssl:make-ssl-client-stream 54 | socket 55 | :unwrap-stream-p t 56 | :external-format '(:iso-8859-1 :eol-style :lf))) 57 | (write-ssl-certificate-names https) 58 | (format https "GET / HTTP/1.0~%Host: ~a~%~%" host) 59 | (force-output https) 60 | (loop :for line = (read-line-crlf-2 https nil) 61 | for cnt from 0 62 | :while line :do 63 | (when show-text-p 64 | (format t "HTTPS> ~a~%" line)) 65 | finally (return cnt))) 66 | (if https 67 | (close https) 68 | (close socket))))) 69 | 70 | (defparameter *rayservers-ca-certificate-pem-file* 71 | "rayservers-ca-certificate.pem") 72 | 73 | (defparameter *rayservers-ca-certificate-path* 74 | (merge-pathnames *rayservers-ca-certificate-pem-file* 75 | (asdf:system-source-directory :cl+ssl))) 76 | 77 | (defparameter *rayservers-ca-certificate-pem* 78 | "-----BEGIN CERTIFICATE----- 79 | MIIElTCCA32gAwIBAgIJALoXNnj+yvJCMA0GCSqGSIb3DQEBBQUAMIGNMQswCQYD 80 | VQQGEwJQQTELMAkGA1UECBMCTkExFDASBgNVBAcTC1BhbmFtYSBDaXR5MRgwFgYD 81 | VQQKEw9SYXlzZXJ2ZXJzIEdtYkgxGjAYBgNVBAMTEWNhLnJheXNlcnZlcnMuY29t 82 | MSUwIwYJKoZIhvcNAQkBFhZzdXBwb3J0QHJheXNlcnZlcnMuY29tMB4XDTA5MTAx 83 | OTE3MzgyMFoXDTE5MTAxNzE3MzgyMFowgY0xCzAJBgNVBAYTAlBBMQswCQYDVQQI 84 | EwJOQTEUMBIGA1UEBxMLUGFuYW1hIENpdHkxGDAWBgNVBAoTD1JheXNlcnZlcnMg 85 | R21iSDEaMBgGA1UEAxMRY2EucmF5c2VydmVycy5jb20xJTAjBgkqhkiG9w0BCQEW 86 | FnN1cHBvcnRAcmF5c2VydmVycy5jb20wggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAw 87 | ggEKAoIBAQC9rNsCCM+TNp6xDk2yxhXQOStmPTd0txFyduNAj02/nLZV4eq0ZS5n 88 | xXBE6l3MYIMBMV3BgKiy7LsdiRJeZ5HdsV/HRZzXCQI+k4acBjlRC1ZdWMNsIR+H 89 | QUVx2y0wgp+QpcMrgBQZdPI7PobnXCZ6+Fmc50kM7xbIsoWZUzQDpRtUymgOhnnT 90 | 4TSb1/XufFHHhDMReRA7s3Co911hzcnZJqL9gFWULlB/RI2ZeVbkp0K4lUXyMZ/R 91 | fnOtCdAA+TkQcpzoyBETV9p5MO8KBOPBskvyGYqVcIZNuxwfC2uoKx0s5b6eMRKR 92 | 54B4mB/hIi7i0uGjzuAZdt5iDXQHYaM3AgMBAAGjgfUwgfIwHQYDVR0OBBYEFOyu 93 | Fp80LSc1gwnq5rghs/P8bMgrMIHCBgNVHSMEgbowgbeAFOyuFp80LSc1gwnq5rgh 94 | s/P8bMgroYGTpIGQMIGNMQswCQYDVQQGEwJQQTELMAkGA1UECBMCTkExFDASBgNV 95 | BAcTC1BhbmFtYSBDaXR5MRgwFgYDVQQKEw9SYXlzZXJ2ZXJzIEdtYkgxGjAYBgNV 96 | BAMTEWNhLnJheXNlcnZlcnMuY29tMSUwIwYJKoZIhvcNAQkBFhZzdXBwb3J0QHJh 97 | eXNlcnZlcnMuY29tggkAuhc2eP7K8kIwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0B 98 | AQUFAAOCAQEAqScS+A2Hajjb+jTKQ19LVPzTpRYo1Jz0SPtzGO91n0efYeRJD5hV 99 | tU+57zGSlUDszARvB+sxzLdJTItK+wEpDM8pLtwUT/VPrRKOoOUBkKBshcTD4HmI 100 | k8uJlNed0QQLP41hFjr+mYd7WM+N5LtFMQAUBMUN6dzEqQIx69EnIoVp0KB8kDwW 101 | /QK5ogKY0g8DmRTFiV036bHQH93kLzyV6FNAldO8vBDqcTeru/uU2Kcn6a8YOfO1 102 | T6MVYory7prWbBaGPKsGw0VgrV9OGbxhbw9EOEYSOgdejvbi9VhgMvEpDYFN7Hnq 103 | 0wiHJq5jKECf3bwRe9uVzVMrIeCap/r2uA== 104 | -----END CERTIFICATE-----") 105 | 106 | (defun write-rayservers-certificate-pem () 107 | (with-open-file (s *rayservers-ca-certificate-path* 108 | :direction :output 109 | :if-exists :supersede 110 | :if-does-not-exist :create) 111 | (write-string *rayservers-ca-certificate-pem* s) 112 | *rayservers-ca-certificate-path*)) 113 | 114 | (defun install-rayservers-ca-certificate () 115 | (let ((path (write-rayservers-certificate-pem))) 116 | (ssl-load-global-verify-locations path))) 117 | 118 | (defun test-loom-client (&optional show-text-p) 119 | (test-https-client-2 "secure.loom.cc" :show-text-p show-text-p)) 120 | 121 | (defun test-yahoo-client (&optional show-text-p) 122 | (test-https-client-2 "yahoo.com" :show-text-p show-text-p)) 123 | 124 | (defmacro expecting-no-errors (&body body) 125 | `(handler-case 126 | (progn ,@body) 127 | (error (c) 128 | (error "Got an unexpected error: ~a" c)))) 129 | 130 | (defmacro expecting-error ((type) &body body) 131 | `(let ((got-error-p nil)) 132 | (handler-case 133 | (progn ,@body) 134 | (error (c) 135 | (unless (typep c ',type) 136 | (error "Got an unexpected error type: ~a" c)) 137 | (setf got-error-p t))) 138 | (unless got-error-p 139 | (error "Did not get expected error.")))) 140 | 141 | (defun test-verify (&optional quietly) 142 | (let ((*standard-output* 143 | ;; test-https-client-2 prints the certificate names 144 | (if quietly (make-broadcast-stream) *standard-output*))) 145 | (expecting-no-errors 146 | (reload) 147 | (test-loom-client) 148 | (test-yahoo-client) 149 | (setf (ssl-check-verify-p) t)) 150 | ;; The Mac appears to have no way to get rid of the default CA certificates 151 | ;; #+darwin-host is only true in Clozure Common Lisp running on a Mac, 152 | ;; So this test will fail in SBCL on a Mac 153 | #-darwin-host 154 | (expecting-error (ssl-error-verify) 155 | (test-yahoo-client)) 156 | #+darwin-host 157 | (expecting-no-errors 158 | (test-yahoo-client)) 159 | (expecting-error (ssl-error-verify) 160 | (test-loom-client)) 161 | (expecting-no-errors 162 | (install-rayservers-ca-certificate) 163 | (test-loom-client)) 164 | (expecting-no-errors 165 | (ssl-set-global-default-verify-paths) 166 | (test-yahoo-client)))) 167 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2008 David Lichteblau 2 | ;;; See LICENSE for details. 3 | 4 | #| 5 | (load "test.lisp") 6 | |# 7 | 8 | (defpackage :ssl-test 9 | (:use :cl)) 10 | (in-package :ssl-test) 11 | 12 | (defvar *port* 8080) 13 | (defvar *cert* "/home/david/newcert.pem") 14 | (defvar *key* "/home/david/newkey.pem") 15 | 16 | (eval-when (:compile-toplevel :load-toplevel :execute) 17 | (asdf:operate 'asdf:load-op :trivial-sockets) 18 | (asdf:operate 'asdf:load-op :bordeaux-threads)) 19 | 20 | (defparameter *tests* '()) 21 | 22 | (defvar *sockets* '()) 23 | (defvar *sockets-lock* (bordeaux-threads:make-lock)) 24 | 25 | (defun record-socket (socket) 26 | (unless (integerp socket) 27 | (bordeaux-threads:with-lock-held (*sockets-lock*) 28 | (push socket *sockets*))) 29 | socket) 30 | 31 | (defun close-socket (socket &key abort) 32 | (if (streamp socket) 33 | (close socket :abort abort) 34 | (trivial-sockets:close-server socket))) 35 | 36 | (defun check-sockets () 37 | (let ((failures nil)) 38 | (bordeaux-threads:with-lock-held (*sockets-lock*) 39 | (dolist (socket *sockets*) 40 | (when (close-socket socket :abort t) 41 | (push socket failures))) 42 | (setf *sockets* nil)) 43 | #-sbcl ;fixme 44 | (when failures 45 | (error "failed to close sockets properly:~{ ~A~%~}" failures)))) 46 | 47 | (defmacro deftest (name &body body) 48 | `(progn 49 | (defun ,name () 50 | (format t "~%----- ~A ----------------------------~%" ',name) 51 | (handler-case 52 | (progn 53 | ,@body 54 | (check-sockets) 55 | (format t "===== [OK] ~A ====================~%" ',name) 56 | t) 57 | (error (c) 58 | (when (typep c 'trivial-sockets:socket-error) 59 | (setf c (trivial-sockets:socket-nested-error c))) 60 | (format t "~%===== [FAIL] ~A: ~A~%" ',name c) 61 | (handler-case 62 | (check-sockets) 63 | (error (c) 64 | (format t "muffling follow-up error ~A~%" c))) 65 | nil))) 66 | (push ',name *tests*))) 67 | 68 | (defun run-all-tests () 69 | (unless (probe-file *cert*) (error "~A not found" *cert*)) 70 | (unless (probe-file *key*) (error "~A not found" *key*)) 71 | (let ((n 0) 72 | (nok 0)) 73 | (dolist (test (reverse *tests*)) 74 | (when (funcall test) 75 | (incf nok)) 76 | (incf n)) 77 | (format t "~&passed ~D/~D tests~%" nok n))) 78 | 79 | (define-condition quit (condition) 80 | ()) 81 | 82 | (defparameter *please-quit* t) 83 | 84 | (defun make-test-thread (name init main &rest args) 85 | "Start a thread named NAME, wait until it has funcalled INIT with ARGS 86 | as arguments, then continue while the thread concurrently funcalls MAIN 87 | with INIT's return values as arguments." 88 | (let ((cv (bordeaux-threads:make-condition-variable)) 89 | (lock (bordeaux-threads:make-lock name)) 90 | ;; redirect io manually, because swan's global redirection isn't as 91 | ;; global as one might hope 92 | (out *terminal-io*) 93 | (init-ok nil)) 94 | (bordeaux-threads:with-lock-held (lock) 95 | (setf *please-quit* nil) 96 | (prog1 97 | (bordeaux-threads:make-thread 98 | (lambda () 99 | (flet ((notify () 100 | (bordeaux-threads:with-lock-held (lock) 101 | (bordeaux-threads:condition-notify cv)))) 102 | (let ((*terminal-io* out) 103 | (*standard-output* out) 104 | (*trace-output* out) 105 | (*error-output* out)) 106 | (handler-case 107 | (let ((values (multiple-value-list (apply init args)))) 108 | (setf init-ok t) 109 | (notify) 110 | (apply main values)) 111 | (quit () 112 | (notify) 113 | t) 114 | (error (c) 115 | (when (typep c 'trivial-sockets:socket-error) 116 | (setf c (trivial-sockets:socket-nested-error c))) 117 | (format t "aborting test thread ~A: ~A" name c) 118 | (notify) 119 | nil))))) 120 | :name name) 121 | (bordeaux-threads:condition-wait cv lock) 122 | (unless init-ok 123 | (error "failed to start background thread")))))) 124 | 125 | (defmacro with-thread ((name init main &rest args) &body body) 126 | `(invoke-with-thread (lambda () ,@body) 127 | ,name 128 | ,init 129 | ,main 130 | ,@args)) 131 | 132 | (defun invoke-with-thread (body name init main &rest args) 133 | (let ((thread (apply #'make-test-thread name init main args))) 134 | (unwind-protect 135 | (funcall body) 136 | (setf *please-quit* t) 137 | (loop 138 | for delay = 0.0001 then (* delay 2) 139 | while (and (< delay 0.5) (bordeaux-threads:thread-alive-p thread)) 140 | do 141 | (sleep delay)) 142 | (when (bordeaux-threads:thread-alive-p thread) 143 | (format t "~&thread doesn't want to quit, killing it~%") 144 | (force-output) 145 | (bordeaux-threads:interrupt-thread thread (lambda () (error 'quit))) 146 | (loop 147 | for delay = 0.0001 then (* delay 2) 148 | while (bordeaux-threads:thread-alive-p thread) 149 | do 150 | (sleep delay)))))) 151 | 152 | (defun init-server (&key (unwrap-stream-p t)) 153 | (format t "~&SSL server listening on port ~d~%" *port*) 154 | (values (record-socket (trivial-sockets:open-server :port *port*)) 155 | unwrap-stream-p)) 156 | 157 | (defun test-server (listening-socket unwrap-stream-p) 158 | (format t "~&SSL server accepting...~%") 159 | (unwind-protect 160 | (let* ((socket (record-socket 161 | (trivial-sockets:accept-connection 162 | listening-socket 163 | :element-type '(unsigned-byte 8)))) 164 | (callback nil)) 165 | (when (eq unwrap-stream-p :caller) 166 | (setf callback (let ((s socket)) (lambda () (close-socket s)))) 167 | (setf socket (cl+ssl:stream-fd socket)) 168 | (setf unwrap-stream-p nil)) 169 | (let ((client (record-socket 170 | (cl+ssl:make-ssl-server-stream 171 | socket 172 | :unwrap-stream-p unwrap-stream-p 173 | :close-callback callback 174 | :external-format :iso-8859-1 175 | :certificate *cert* 176 | :key *key*)))) 177 | (unwind-protect 178 | (loop 179 | for line = (prog2 180 | (when *please-quit* (return)) 181 | (read-line client nil) 182 | (when *please-quit* (return))) 183 | while line 184 | do 185 | (cond 186 | ((equal line "freeze") 187 | (format t "~&Freezing on client request~%") 188 | (loop 189 | (sleep 1) 190 | (when *please-quit* (return)))) 191 | (t 192 | (format t "~&Responding to query ~A...~%" line) 193 | (format client "(echo ~A)~%" line) 194 | (force-output client)))) 195 | (close-socket client)))) 196 | (close-socket listening-socket))) 197 | 198 | (defun init-client (&key (unwrap-stream-p t)) 199 | (let ((socket (record-socket 200 | (trivial-sockets:open-stream 201 | "127.0.0.1" 202 | *port* 203 | :element-type '(unsigned-byte 8)))) 204 | (callback nil)) 205 | (when (eq unwrap-stream-p :caller) 206 | (setf callback (let ((s socket)) (lambda () (close-socket s)))) 207 | (setf socket (cl+ssl:stream-fd socket)) 208 | (setf unwrap-stream-p nil)) 209 | (cl+ssl:make-ssl-client-stream 210 | socket 211 | :unwrap-stream-p unwrap-stream-p 212 | :close-callback callback 213 | :external-format :iso-8859-1))) 214 | 215 | ;; CCL requires specifying the 216 | ;; deadline at the socket cration ( 217 | ;; in constrast to SBCL which has 218 | ;; the WITH-TIMEOUT macro). 219 | ;; 220 | ;; Therefore a separate INIT-CLIENT 221 | ;; function is needed for CCL when 222 | ;; we need read/write deadlines on 223 | ;; the SSL client stream. 224 | #+clozure-common-lisp 225 | (defun ccl-init-client-with-deadline (&key (unwrap-stream-p t) 226 | seconds) 227 | (let* ((deadline 228 | (+ (get-internal-real-time) 229 | (* seconds internal-time-units-per-second))) 230 | (low 231 | (record-socket 232 | (ccl:make-socket 233 | :address-family :internet 234 | :connect :active 235 | :type :stream 236 | :remote-host "127.0.0.1" 237 | :remote-port *port* 238 | :deadline deadline)))) 239 | (cl+ssl:make-ssl-client-stream 240 | low 241 | :unwrap-stream-p unwrap-stream-p 242 | :external-format :iso-8859-1))) 243 | 244 | ;;; Simple echo-server test. Write a line and check that the result 245 | ;;; watches, three times in a row. 246 | (deftest echo 247 | (with-thread ("simple server" #'init-server #'test-server) 248 | (with-open-stream (socket (init-client)) 249 | (write-line "test" socket) 250 | (force-output socket) 251 | (assert (equal (read-line socket) "(echo test)")) 252 | (write-line "test2" socket) 253 | (force-output socket) 254 | (assert (equal (read-line socket) "(echo test2)")) 255 | (write-line "test3" socket) 256 | (force-output socket) 257 | (assert (equal (read-line socket) "(echo test3)"))))) 258 | 259 | ;;; Run tests with different BIO setup strategies: 260 | ;;; - :UNWRAP-STREAMS T 261 | ;;; In this case, CL+SSL will convert the socket to a file descriptor. 262 | ;;; - :UNWRAP-STREAMS :CLIENT 263 | ;;; Convert the socket to a file descriptor manually, and give that 264 | ;;; to CL+SSL. 265 | ;;; - :UNWRAP-STREAMS NIL 266 | ;;; Let CL+SSL write to the stream directly, using the Lisp BIO. 267 | (macrolet ((deftests (name (var &rest values) &body body) 268 | `(progn 269 | ,@(loop 270 | for value in values 271 | collect 272 | `(deftest ,(intern (format nil "~A-~A" name value)) 273 | (let ((,var ',value)) 274 | ,@body)))))) 275 | 276 | (deftests unwrap-strategy (usp nil t :caller) 277 | (with-thread ("echo server for strategy test" 278 | (lambda () (init-server :unwrap-stream-p usp)) 279 | #'test-server) 280 | (with-open-stream (socket (init-client :unwrap-stream-p usp)) 281 | (write-line "test" socket) 282 | (force-output socket) 283 | (assert (equal (read-line socket) "(echo test)"))))) 284 | 285 | #+clozure-common-lisp 286 | (deftests read-deadline (usp nil t :caller) 287 | (with-thread ("echo server for deadline test" 288 | (lambda () (init-server :unwrap-stream-p usp)) 289 | #'test-server) 290 | (with-open-stream 291 | (socket 292 | (ccl-init-client-with-deadline 293 | :unwrap-stream-p usp 294 | :seconds 3)) 295 | (write-line "test" socket) 296 | (force-output socket) 297 | (assert (equal (read-line socket) "(echo test)")) 298 | (handler-case 299 | (progn 300 | (read-char socket) 301 | (error "unexpected data")) 302 | (ccl::communication-deadline-expired ()))))) 303 | 304 | #+sbcl 305 | (deftests read-deadline (usp nil t :caller) 306 | (with-thread ("echo server for deadline test" 307 | (lambda () (init-server :unwrap-stream-p usp)) 308 | #'test-server) 309 | (sb-sys:with-deadline (:seconds 3) 310 | (with-open-stream (socket (init-client :unwrap-stream-p usp)) 311 | (write-line "test" socket) 312 | (force-output socket) 313 | (assert (equal (read-line socket) "(echo test)")) 314 | (handler-case 315 | (progn 316 | (read-char socket) 317 | (error "unexpected data")) 318 | (sb-sys:deadline-timeout ())))))) 319 | 320 | #+clozure-common-lisp 321 | (deftests write-deadline (usp nil t) 322 | (with-thread ("echo server for deadline test" 323 | (lambda () (init-server :unwrap-stream-p usp)) 324 | #'test-server) 325 | (with-open-stream 326 | (socket 327 | (ccl-init-client-with-deadline 328 | :unwrap-stream-p usp 329 | :seconds 3)) 330 | (unwind-protect 331 | (progn 332 | (write-line "test" socket) 333 | (force-output socket) 334 | (assert (equal (read-line socket) "(echo test)")) 335 | (write-line "freeze" socket) 336 | (force-output socket) 337 | (let ((n 0)) 338 | (handler-case 339 | (loop 340 | (write-line "deadbeef" socket) 341 | (incf n)) 342 | (ccl::communication-deadline-expired ())) 343 | ;; should have written a couple of lines before the deadline: 344 | (assert (> n 100)))) 345 | (handler-case 346 | (close-socket socket :abort t) 347 | (ccl::communication-deadline-expired ())))))) 348 | 349 | #+sbcl 350 | (deftests write-deadline (usp nil t) 351 | (with-thread ("echo server for deadline test" 352 | (lambda () (init-server :unwrap-stream-p usp)) 353 | #'test-server) 354 | (with-open-stream (socket (init-client :unwrap-stream-p usp)) 355 | (unwind-protect 356 | (sb-sys:with-deadline (:seconds 3) 357 | (write-line "test" socket) 358 | (force-output socket) 359 | (assert (equal (read-line socket) "(echo test)")) 360 | (write-line "freeze" socket) 361 | (force-output socket) 362 | (let ((n 0)) 363 | (handler-case 364 | (loop 365 | (write-line "deadbeef" socket) 366 | (incf n)) 367 | (sb-sys:deadline-timeout ())) 368 | ;; should have written a couple of lines before the deadline: 369 | (assert (> n 100)))) 370 | (handler-case 371 | (close-socket socket :abort t) 372 | (sb-sys:deadline-timeout ())))))) 373 | 374 | #+clozure-common-lisp 375 | (deftests read-char-no-hang/test (usp nil t :caller) 376 | (with-thread ("echo server for read-char-no-hang test" 377 | (lambda () (init-server :unwrap-stream-p usp)) 378 | #'test-server) 379 | (with-open-stream 380 | (socket (ccl-init-client-with-deadline 381 | :unwrap-stream-p usp 382 | :seconds 3)) 383 | (write-line "test" socket) 384 | (force-output socket) 385 | (assert (equal (read-line socket) "(echo test)")) 386 | (handler-case 387 | (when (read-char-no-hang socket) 388 | (error "unexpected data")) 389 | (ccl::communication-deadline-expired () 390 | (error "read-char-no-hang hangs")))))) 391 | 392 | #+sbcl 393 | (deftests read-char-no-hang/test (usp nil t :caller) 394 | (with-thread ("echo server for read-char-no-hang test" 395 | (lambda () (init-server :unwrap-stream-p usp)) 396 | #'test-server) 397 | (sb-sys:with-deadline (:seconds 3) 398 | (with-open-stream (socket (init-client :unwrap-stream-p usp)) 399 | (write-line "test" socket) 400 | (force-output socket) 401 | (assert (equal (read-line socket) "(echo test)")) 402 | (handler-case 403 | (when (read-char-no-hang socket) 404 | (error "unexpected data")) 405 | (sb-sys:deadline-timeout () 406 | (error "read-char-no-hang hangs")))))))) 407 | 408 | #+(or) 409 | (run-all-tests) 410 | -------------------------------------------------------------------------------- /conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2001, 2003 Eric Marsden 2 | ;;; Copyright (C) 2005 David Lichteblau 3 | ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." 4 | ;;; 5 | ;;; See LICENSE for details. 6 | 7 | #+xcvb (module (:depends-on ("package"))) 8 | 9 | (in-package :cl+ssl) 10 | 11 | (eval-when (:compile-toplevel :load-toplevel :execute) 12 | (defconstant +ssl-error-none+ 0) 13 | (defconstant +ssl-error-ssl+ 1) 14 | (defconstant +ssl-error-want-read+ 2) 15 | (defconstant +ssl-error-want-write+ 3) 16 | (defconstant +ssl-error-want-x509-lookup+ 4) 17 | (defconstant +ssl-error-syscall+ 5) 18 | (defconstant +ssl-error-zero-return+ 6) 19 | (defconstant +ssl-error-want-connect+ 7)) 20 | 21 | 22 | ;;; Condition hierarchy 23 | ;;; 24 | 25 | (defun read-ssl-error-queue () 26 | (loop 27 | :for error-code = (err-get-error) 28 | :until (zerop error-code) 29 | :collect error-code)) 30 | 31 | (defun format-ssl-error-queue (stream-designator queue-designator) 32 | "STREAM-DESIGNATOR is the same as CL:FORMAT accepts: T, NIL, or a stream. 33 | QUEUE-DESIGNATOR is either a list of error codes (as returned 34 | by READ-SSL-ERROR-QUEUE) or an SSL-ERROR condition." 35 | (flet ((body (stream) 36 | (let ((queue (etypecase queue-designator 37 | (ssl-error (ssl-error-queue queue-designator)) 38 | (list queue-designator)))) 39 | (format stream "SSL error queue") 40 | (if queue 41 | (progn 42 | (format stream ":~%") 43 | (loop 44 | :for error-code :in queue 45 | :do (format stream "~a~%" (err-error-string error-code (cffi:null-pointer))))) 46 | (format stream " is empty."))))) 47 | (case stream-designator 48 | ((t) (body *standard-output*)) 49 | ((nil) (let ((s (make-string-output-stream :element-type 'character))) 50 | (unwind-protect 51 | (body s) 52 | (close s)) 53 | (get-output-stream-string s))) 54 | (otherwise (body stream-designator))))) 55 | 56 | (define-condition ssl-error (error) 57 | ( 58 | ;; Stores list of error codes 59 | ;; (as returned by the READ-SSL-ERROR-QUEUE function) 60 | (queue :initform nil :initarg :queue :reader ssl-error-queue))) 61 | 62 | (define-condition ssl-error/handle (ssl-error) 63 | ((ret :initarg :ret 64 | :reader ssl-error-ret) 65 | (handle :initarg :handle 66 | :reader ssl-error-handle)) 67 | (:report (lambda (condition stream) 68 | (format stream "Unspecified error ~A on handle ~A" 69 | (ssl-error-ret condition) 70 | (ssl-error-handle condition)) 71 | (format-ssl-error-queue stream condition)))) 72 | 73 | (define-condition ssl-error-initialize (ssl-error) 74 | ((reason :initarg :reason 75 | :reader ssl-error-reason)) 76 | (:report (lambda (condition stream) 77 | (format stream "SSL initialization error: ~A" 78 | (ssl-error-reason condition)) 79 | (format-ssl-error-queue stream condition)))) 80 | 81 | 82 | (define-condition ssl-error-want-something (ssl-error/handle) 83 | ()) 84 | 85 | ;;;SSL_ERROR_NONE 86 | (define-condition ssl-error-none (ssl-error/handle) 87 | () 88 | (:documentation 89 | "The TLS/SSL I/O operation completed. This result code is returned if and 90 | only if ret > 0.") 91 | (:report (lambda (condition stream) 92 | (format stream "The TLS/SSL operation on handle ~A completed (return code: ~A). " 93 | (ssl-error-handle condition) 94 | (ssl-error-ret condition)) 95 | (format-ssl-error-queue stream condition)))) 96 | 97 | ;; SSL_ERROR_ZERO_RETURN 98 | (define-condition ssl-error-zero-return (ssl-error/handle) 99 | () 100 | (:documentation 101 | "The TLS/SSL connection has been closed. If the protocol version is SSL 3.0 102 | or TLS 1.0, this result code is returned only if a closure alert has 103 | occurred in the protocol, i.e. if the connection has been closed cleanly. 104 | Note that in this case SSL_ERROR_ZERO_RETURN 105 | does not necessarily indicate that the underlying transport has been 106 | closed.") 107 | (:report (lambda (condition stream) 108 | (format stream "The TLS/SSL connection on handle ~A has been closed (return code: ~A). " 109 | (ssl-error-handle condition) 110 | (ssl-error-ret condition)) 111 | (format-ssl-error-queue stream condition)))) 112 | 113 | ;; SSL_ERROR_WANT_READ 114 | (define-condition ssl-error-want-read (ssl-error-want-something) 115 | () 116 | (:documentation 117 | "The operation did not complete; the same TLS/SSL I/O function should be 118 | called again later. If, by then, the underlying BIO has data available for 119 | reading (if the result code is SSL_ERROR_WANT_READ) or allows writing data 120 | (SSL_ERROR_WANT_WRITE), then some TLS/SSL protocol progress will take place, 121 | i.e. at least part of an TLS/SSL record will be read or written. Note that 122 | the retry may again lead to a SSL_ERROR_WANT_READ or SSL_ERROR_WANT_WRITE 123 | condition. There is no fixed upper limit for the number of iterations that 124 | may be necessary until progress becomes visible at application protocol 125 | level.") 126 | (:report (lambda (condition stream) 127 | (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a READ (return code: ~A). " 128 | (ssl-error-handle condition) 129 | (ssl-error-ret condition)) 130 | (format-ssl-error-queue stream condition)))) 131 | 132 | ;; SSL_ERROR_WANT_WRITE 133 | (define-condition ssl-error-want-write (ssl-error-want-something) 134 | () 135 | (:documentation 136 | "The operation did not complete; the same TLS/SSL I/O function should be 137 | called again later. If, by then, the underlying BIO has data available for 138 | reading (if the result code is SSL_ERROR_WANT_READ) or allows writing data 139 | (SSL_ERROR_WANT_WRITE), then some TLS/SSL protocol progress will take place, 140 | i.e. at least part of an TLS/SSL record will be read or written. Note that 141 | the retry may again lead to a SSL_ERROR_WANT_READ or SSL_ERROR_WANT_WRITE 142 | condition. There is no fixed upper limit for the number of iterations that 143 | may be necessary until progress becomes visible at application protocol 144 | level.") 145 | (:report (lambda (condition stream) 146 | (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a WRITE (return code: ~A). " 147 | (ssl-error-handle condition) 148 | (ssl-error-ret condition)) 149 | (format-ssl-error-queue stream condition)))) 150 | 151 | ;; SSL_ERROR_WANT_CONNECT 152 | (define-condition ssl-error-want-connect (ssl-error-want-something) 153 | () 154 | (:documentation 155 | "The operation did not complete; the same TLS/SSL I/O function should be 156 | called again later. The underlying BIO was not connected yet to the peer 157 | and the call would block in connect()/accept(). The SSL 158 | function should be called again when the connection is established. These 159 | messages can only appear with a BIO_s_connect() or 160 | BIO_s_accept() BIO, respectively. In order to find out, when 161 | the connection has been successfully established, on many platforms 162 | select() or poll() for writing on the socket file 163 | descriptor can be used.") 164 | (:report (lambda (condition stream) 165 | (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a connect first (return code: ~A). " 166 | (ssl-error-handle condition) 167 | (ssl-error-ret condition)) 168 | (format-ssl-error-queue stream condition)))) 169 | 170 | ;; SSL_ERROR_WANT_X509_LOOKUP 171 | (define-condition ssl-error-want-x509-lookup (ssl-error-want-something) 172 | () 173 | (:documentation 174 | "The operation did not complete because an application callback set by 175 | SSL_CTX_set_client_cert_cb() has asked to be called again. The 176 | TLS/SSL I/O function should be called again later. Details depend on the 177 | application.") 178 | (:report (lambda (condition stream) 179 | (format stream "The TLS/SSL operation on handle ~A did not complete: An application callback wants to be called again (return code: ~A). " 180 | (ssl-error-handle condition) 181 | (ssl-error-ret condition)) 182 | (format-ssl-error-queue stream condition)))) 183 | 184 | ;; SSL_ERROR_SYSCALL 185 | (define-condition ssl-error-syscall (ssl-error/handle) 186 | ((syscall :initarg :syscall)) 187 | (:documentation 188 | "Some I/O error occurred. The OpenSSL error queue may contain more 189 | information on the error. If the error queue is empty (i.e. ERR_get_error() returns 0), 190 | ret can be used to find out more about the error: If ret == 0, an EOF was observed that 191 | violates the protocol. If ret == -1, the underlying BIO reported an I/O error (for socket 192 | I/O on Unix systems, consult errno for details).") 193 | (:report (lambda (condition stream) 194 | (if (zerop (length (ssl-error-queue condition))) 195 | (case (ssl-error-ret condition) 196 | (0 (format stream "An I/O error occurred: An unexpected EOF was observed on handle ~A (return code: ~A). " 197 | (ssl-error-handle condition) 198 | (ssl-error-ret condition))) 199 | (-1 (format stream "An I/O error occurred in the underlying BIO (return code: ~A). " 200 | (ssl-error-ret condition))) 201 | (otherwise (format stream "An I/O error occurred: undocumented reason (return code: ~A). " 202 | (ssl-error-ret condition)))) 203 | (format stream "An UNKNOWN I/O error occurred in the underlying BIO (return code: ~A). " 204 | (ssl-error-ret condition))) 205 | (format-ssl-error-queue stream condition)))) 206 | 207 | ;; SSL_ERROR_SSL 208 | (define-condition ssl-error-ssl (ssl-error/handle) 209 | () 210 | (:documentation 211 | "A failure in the SSL library occurred, usually a protocol error. The 212 | OpenSSL error queue contains more information on the error.") 213 | (:report (lambda (condition stream) 214 | (format stream 215 | "A failure in the SSL library occurred on handle ~A (return code: ~A). " 216 | (ssl-error-handle condition) 217 | (ssl-error-ret condition)) 218 | (format-ssl-error-queue stream condition)))) 219 | 220 | (defun ssl-signal-error (handle syscall error-code original-error) 221 | (let ((queue (read-ssl-error-queue))) 222 | (if (and (eql error-code #.+ssl-error-syscall+) 223 | (not (zerop original-error))) 224 | (error 'ssl-error-syscall 225 | :handle handle 226 | :ret error-code 227 | :queue queue 228 | :syscall syscall) 229 | (error (case error-code 230 | (#.+ssl-error-none+ 'ssl-error-none) 231 | (#.+ssl-error-ssl+ 'ssl-error-ssl) 232 | (#.+ssl-error-want-read+ 'ssl-error-want-read) 233 | (#.+ssl-error-want-write+ 'ssl-error-want-write) 234 | (#.+ssl-error-want-x509-lookup+ 'ssl-error-want-x509-lookup) 235 | (#.+ssl-error-zero-return+ 'ssl-error-zero-return) 236 | (#.+ssl-error-want-connect+ 'ssl-error-want-connect) 237 | (#.+ssl-error-syscall+ 'ssl-error-zero-return) ; this is intentional here. we got an EOF from the syscall (ret is 0) 238 | (t 'ssl-error/handle)) 239 | :handle handle 240 | :ret error-code 241 | :queue queue)))) 242 | 243 | (defparameter *ssl-verify-error-alist* 244 | '((0 :X509_V_OK) 245 | (2 :X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT) 246 | (3 :X509_V_ERR_UNABLE_TO_GET_CRL) 247 | (4 :X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE) 248 | (5 :X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE) 249 | (6 :X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY) 250 | (7 :X509_V_ERR_CERT_SIGNATURE_FAILURE) 251 | (8 :X509_V_ERR_CRL_SIGNATURE_FAILURE) 252 | (9 :X509_V_ERR_CERT_NOT_YET_VALID) 253 | (10 :X509_V_ERR_CERT_HAS_EXPIRED) 254 | (11 :X509_V_ERR_CRL_NOT_YET_VALID) 255 | (12 :X509_V_ERR_CRL_HAS_EXPIRED) 256 | (13 :X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD) 257 | (14 :X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD) 258 | (15 :X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD) 259 | (16 :X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD) 260 | (17 :X509_V_ERR_OUT_OF_MEM) 261 | (18 :X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT) 262 | (19 :X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN) 263 | (20 :X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY) 264 | (21 :X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE) 265 | (22 :X509_V_ERR_CERT_CHAIN_TOO_LONG) 266 | (23 :X509_V_ERR_CERT_REVOKED) 267 | (24 :X509_V_ERR_INVALID_CA) 268 | (25 :X509_V_ERR_PATH_LENGTH_EXCEEDED) 269 | (26 :X509_V_ERR_INVALID_PURPOSE) 270 | (27 :X509_V_ERR_CERT_UNTRUSTED) 271 | (28 :X509_V_ERR_CERT_REJECTED) 272 | (29 :X509_V_ERR_SUBJECT_ISSUER_MISMATCH) 273 | (30 :X509_V_ERR_AKID_SKID_MISMATCH) 274 | (31 :X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH) 275 | (32 :X509_V_ERR_KEYUSAGE_NO_CERTSIGN) 276 | (50 :X509_V_ERR_APPLICATION_VERIFICATION))) 277 | 278 | (defun ssl-verify-error-keyword (code) 279 | (cadr (assoc code *ssl-verify-error-alist*))) 280 | 281 | (defun ssl-verify-error-code (keyword) 282 | (caar (member keyword *ssl-verify-error-alist* :key #'cadr))) 283 | 284 | (define-condition ssl-error-verify (ssl-error) 285 | ((stream :initarg :stream 286 | :reader ssl-error-stream 287 | :documentation "The SSL stream whose peer certificate didn't verify.") 288 | (error-code :initarg :error-code 289 | :reader ssl-error-code 290 | :documentation "The peer certificate verification error code.")) 291 | (:report (lambda (condition stream) 292 | (let ((code (ssl-error-code condition))) 293 | (format stream "SSL verify error: ~d~@[ ~a~]" 294 | code (ssl-verify-error-keyword code))))) 295 | (:documentation "This condition is signalled on SSL connection when a peer certificate doesn't verify.")) 296 | -------------------------------------------------------------------------------- /streams.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2001, 2003 Eric Marsden 2 | ;;; Copyright (C) 2005 David Lichteblau 3 | ;;; Copyright (C) 2007 Pixel // pinterface 4 | ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." 5 | ;;; 6 | ;;; See LICENSE for details. 7 | 8 | #+xcvb 9 | (module 10 | (:depends-on ("package" "conditions" "ffi" 11 | (:cond ((:featurep :clisp) "ffi-buffer-clisp") 12 | (t "ffi-buffer")) 13 | "ffi-buffer-all"))) 14 | 15 | (eval-when (:compile-toplevel) 16 | (declaim 17 | (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0)))) 18 | 19 | (in-package :cl+ssl) 20 | 21 | ;; Default Cipher List 22 | (defvar *default-cipher-list* "ALL") 23 | 24 | (defclass ssl-stream 25 | (trivial-gray-stream-mixin 26 | fundamental-binary-input-stream 27 | fundamental-binary-output-stream) 28 | ((ssl-stream-socket 29 | :initarg :socket 30 | :accessor ssl-stream-socket) 31 | (close-callback 32 | :initarg :close-callback 33 | :accessor ssl-close-callback) 34 | (handle 35 | :initform nil 36 | :accessor ssl-stream-handle) 37 | (deadline 38 | :initform nil 39 | :initarg :deadline 40 | :accessor ssl-stream-deadline) 41 | (output-buffer 42 | :initform (make-buffer +initial-buffer-size+) 43 | :accessor ssl-stream-output-buffer) 44 | (output-pointer 45 | :initform 0 46 | :accessor ssl-stream-output-pointer) 47 | (input-buffer 48 | :initform (make-buffer +initial-buffer-size+) 49 | :accessor ssl-stream-input-buffer) 50 | (peeked-byte 51 | :initform nil 52 | :accessor ssl-stream-peeked-byte))) 53 | 54 | (defmethod print-object ((object ssl-stream) stream) 55 | (print-unreadable-object (object stream :type t) 56 | (format stream "for ~A" (ssl-stream-socket object)))) 57 | 58 | (defclass ssl-server-stream (ssl-stream) 59 | ((certificate 60 | :initarg :certificate 61 | :accessor ssl-stream-certificate) 62 | (key 63 | :initarg :key 64 | :accessor ssl-stream-key))) 65 | 66 | (defmethod stream-element-type ((stream ssl-stream)) 67 | '(unsigned-byte 8)) 68 | 69 | (defmethod close ((stream ssl-stream) &key abort) 70 | (cond 71 | ((ssl-stream-handle stream) 72 | (unless abort 73 | (force-output stream)) 74 | (ssl-free (ssl-stream-handle stream)) 75 | (setf (ssl-stream-handle stream) nil) 76 | (when (streamp (ssl-stream-socket stream)) 77 | (close (ssl-stream-socket stream))) 78 | (when (ssl-close-callback stream) 79 | (funcall (ssl-close-callback stream))) 80 | t) 81 | (t 82 | nil))) 83 | 84 | (defmethod open-stream-p ((stream ssl-stream)) 85 | (and (ssl-stream-handle stream) t)) 86 | 87 | (defmethod stream-listen ((stream ssl-stream)) 88 | (or (ssl-stream-peeked-byte stream) 89 | (setf (ssl-stream-peeked-byte stream) 90 | (let* ((buf (ssl-stream-input-buffer stream)) 91 | (handle (ssl-stream-handle stream)) 92 | (*blockp* nil) ;; for the Lisp-BIO 93 | (n (with-pointer-to-vector-data (ptr buf) 94 | (nonblocking-ssl-funcall 95 | stream handle #'ssl-read handle ptr 1)))) 96 | (and (> n 0) (buffer-elt buf 0)))))) 97 | 98 | (defmethod stream-read-byte ((stream ssl-stream)) 99 | (or (prog1 100 | (ssl-stream-peeked-byte stream) 101 | (setf (ssl-stream-peeked-byte stream) nil)) 102 | (handler-case 103 | (let ((buf (ssl-stream-input-buffer stream)) 104 | (handle (ssl-stream-handle stream))) 105 | (with-pointer-to-vector-data (ptr buf) 106 | (ensure-ssl-funcall 107 | stream handle #'ssl-read handle ptr 1)) 108 | (buffer-elt buf 0)) 109 | (ssl-error-zero-return () ;SSL_read returns 0 on end-of-file 110 | :eof)))) 111 | 112 | (defmethod stream-read-sequence ((stream ssl-stream) seq start end &key) 113 | (when (and (< start end) (ssl-stream-peeked-byte stream)) 114 | (setf (elt seq start) (ssl-stream-peeked-byte stream)) 115 | (setf (ssl-stream-peeked-byte stream) nil) 116 | (incf start)) 117 | (let ((buf (ssl-stream-input-buffer stream)) 118 | (handle (ssl-stream-handle stream))) 119 | (loop 120 | for length = (min (- end start) (buffer-length buf)) 121 | while (plusp length) 122 | do 123 | (handler-case 124 | (let ((read-bytes 125 | (with-pointer-to-vector-data (ptr buf) 126 | (ensure-ssl-funcall 127 | stream handle #'ssl-read handle ptr length)))) 128 | (s/b-replace seq buf :start1 start :end1 (+ start read-bytes)) 129 | (incf start read-bytes)) 130 | (ssl-error-zero-return () ;SSL_read returns 0 on end-of-file 131 | (return)))) 132 | ;; fixme: kein out-of-file wenn (zerop start)? 133 | start)) 134 | 135 | (defmethod stream-write-byte ((stream ssl-stream) b) 136 | (let ((buf (ssl-stream-output-buffer stream))) 137 | (when (eql (buffer-length buf) (ssl-stream-output-pointer stream)) 138 | (force-output stream)) 139 | (setf (buffer-elt buf (ssl-stream-output-pointer stream)) b) 140 | (incf (ssl-stream-output-pointer stream))) 141 | b) 142 | 143 | (defmethod stream-write-sequence ((stream ssl-stream) seq start end &key) 144 | (let ((buf (ssl-stream-output-buffer stream))) 145 | (when (> (+ (- end start) (ssl-stream-output-pointer stream)) (buffer-length buf)) 146 | ;; not enough space left? flush buffer. 147 | (force-output stream) 148 | ;; still doesn't fit? 149 | (while (> (- end start) (buffer-length buf)) 150 | (b/s-replace buf seq :start2 start) 151 | (incf start (buffer-length buf)) 152 | (setf (ssl-stream-output-pointer stream) (buffer-length buf)) 153 | (force-output stream))) 154 | (b/s-replace buf seq 155 | :start1 (ssl-stream-output-pointer stream) 156 | :start2 start 157 | :end2 end) 158 | (incf (ssl-stream-output-pointer stream) (- end start))) 159 | seq) 160 | 161 | (defmethod stream-finish-output ((stream ssl-stream)) 162 | (stream-force-output stream)) 163 | 164 | (defmethod stream-force-output ((stream ssl-stream)) 165 | (let ((buf (ssl-stream-output-buffer stream)) 166 | (fill-ptr (ssl-stream-output-pointer stream)) 167 | (handle (ssl-stream-handle stream))) 168 | (when (plusp fill-ptr) 169 | (unless handle 170 | (error "output operation on closed SSL stream")) 171 | (with-pointer-to-vector-data (ptr buf) 172 | (ensure-ssl-funcall stream handle #'ssl-write handle ptr fill-ptr)) 173 | (setf (ssl-stream-output-pointer stream) 0)))) 174 | 175 | #+(and clozure-common-lisp (not windows)) 176 | (defun install-nonblock-flag (fd) 177 | (ccl::fd-set-flags fd (logior (ccl::fd-get-flags fd) 178 | #.(read-from-string "#$O_NONBLOCK")))) 179 | ;; read-from-string is necessary because 180 | ;; CLISP and perhaps other Lisps are confused 181 | ;; by #$, signaling"undefined dispatch character $", 182 | ;; even though the defun in conditionalized by 183 | ;; #+clozure-common-lisp 184 | 185 | #+(and sbcl (not win32)) 186 | (defun install-nonblock-flag (fd) 187 | (sb-posix:fcntl fd 188 | sb-posix::f-setfl 189 | (logior (sb-posix:fcntl fd sb-posix::f-getfl) 190 | sb-posix::o-nonblock))) 191 | 192 | #-(or (and clozure-common-lisp (not windows)) sbcl) 193 | (defun install-nonblock-flag (fd) 194 | (declare (ignore fd))) 195 | 196 | #+(and sbcl win32) 197 | (defun install-nonblock-flag (fd) 198 | (when (boundp 'sockint::fionbio) 199 | (sockint::ioctl fd sockint::fionbio 1))) 200 | 201 | ;;; interface functions 202 | ;;; 203 | 204 | (defun install-handle-and-bio (stream handle socket unwrap-stream-p) 205 | (setf (ssl-stream-handle stream) handle) 206 | (when unwrap-stream-p 207 | (let ((fd (stream-fd socket))) 208 | (when fd 209 | (setf socket fd)))) 210 | (etypecase socket 211 | (integer 212 | (install-nonblock-flag socket) 213 | (ssl-set-fd handle socket)) 214 | (stream 215 | (ssl-set-bio handle (bio-new-lisp) (bio-new-lisp)))) 216 | (ssl-ctx-ctrl handle 217 | +SSL_CTRL_MODE+ 218 | +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 219 | (cffi:null-pointer)) 220 | socket) 221 | 222 | (defun install-key-and-cert (handle key certificate) 223 | (when key 224 | (unless (eql 1 (ssl-use-rsa-privatekey-file handle 225 | key 226 | +ssl-filetype-pem+)) 227 | (error 'ssl-error-initialize :reason (format nil "Can't load RSA private key file ~A" key)))) 228 | (when certificate 229 | (unless (eql 1 (ssl-use-certificate-file handle 230 | certificate 231 | +ssl-filetype-pem+)) 232 | (error 'ssl-error-initialize 233 | :reason (format nil "Can't load certificate ~A" certificate))))) 234 | 235 | (defun x509-certificate-names (x509-certificate) 236 | (unless (cffi:null-pointer-p x509-certificate) 237 | (cffi:with-foreign-pointer (buf 1024) 238 | (let ((issuer-name (x509-get-issuer-name x509-certificate)) 239 | (subject-name (x509-get-subject-name x509-certificate))) 240 | (values 241 | (unless (cffi:null-pointer-p issuer-name) 242 | (x509-name-oneline issuer-name buf 1024) 243 | (cffi:foreign-string-to-lisp buf)) 244 | (unless (cffi:null-pointer-p subject-name) 245 | (x509-name-oneline subject-name buf 1024) 246 | (cffi:foreign-string-to-lisp buf))))))) 247 | 248 | (defmethod ssl-stream-handle ((stream flexi-streams:flexi-stream)) 249 | (ssl-stream-handle (flexi-streams:flexi-stream-stream stream))) 250 | 251 | (defun ssl-stream-x509-certificate (ssl-stream) 252 | (ssl-get-peer-certificate (ssl-stream-handle ssl-stream))) 253 | 254 | (defun ssl-load-global-verify-locations (&rest pathnames) 255 | "PATHNAMES is a list of pathnames to PEM files containing server and CA certificates. 256 | Install these certificates to use for verifying on all SSL connections. 257 | After RELOAD, you need to call this again." 258 | (ensure-initialized) 259 | (dolist (path pathnames) 260 | (let ((namestring (namestring (truename path)))) 261 | (cffi:with-foreign-strings ((cafile namestring)) 262 | (unless (eql 1 (ssl-ctx-load-verify-locations 263 | *ssl-global-context* 264 | cafile 265 | (cffi:null-pointer))) 266 | (error "ssl-ctx-load-verify-locations failed.")))))) 267 | 268 | (defun ssl-set-global-default-verify-paths () 269 | "Load the system default verification certificates. 270 | After RELOAD, you need to call this again." 271 | (ensure-initialized) 272 | (unless (eql 1 (ssl-ctx-set-default-verify-paths *ssl-global-context*)) 273 | (error "ssl-ctx-set-default-verify-paths failed."))) 274 | 275 | (defun ssl-check-verify-p () 276 | "Return true if SSL connections will error if the certificate doesn't verify." 277 | (and *ssl-check-verify-p* (not (eq *ssl-check-verify-p* :unspecified)))) 278 | 279 | (defun (setf ssl-check-verify-p) (check-verify-p) 280 | "If CHECK-VERIFY-P is true, signal connection errors if the server certificate doesn't verify." 281 | (setf *ssl-check-verify-p* (not (null check-verify-p)))) 282 | 283 | (defun ssl-verify-init (&key 284 | (verify-depth nil) 285 | (verify-locations nil)) 286 | (check-type verify-depth (or null integer)) 287 | (ensure-initialized) 288 | (when verify-depth 289 | (ssl-ctx-set-verify-depth *ssl-global-context* verify-depth)) 290 | (when verify-locations 291 | (apply #'ssl-load-global-verify-locations verify-locations) 292 | ;; This makes (setf (ssl-check-verify) nil) persistent 293 | (unless (null *ssl-check-verify-p*) 294 | (setf (ssl-check-verify-p) t)) 295 | t)) 296 | 297 | (defun ssl-stream-check-verify (ssl-stream) 298 | (let* ((handle (ssl-stream-handle ssl-stream)) 299 | (err (ssl-get-verify-result handle))) 300 | (unless (eql err 0) 301 | (error 'ssl-error-verify :stream ssl-stream :error-code err)))) 302 | 303 | (defun handle-external-format (stream ef) 304 | (if ef 305 | (flexi-streams:make-flexi-stream stream :external-format ef) 306 | stream)) 307 | 308 | (defun handle-servername (stream handle servername) 309 | (cffi:with-foreign-object (sni '(:struct tlsextctx)) 310 | (cffi:with-foreign-slots ((biodebug) sni (:struct tlsextctx)) 311 | (setf biodebug (cffi:null-pointer)) 312 | (let ((ctx *ssl-global-context*)) 313 | (ssl-ctx-set-tlsext-servername-callback 314 | ctx 315 | (cffi:callback lisp-ssl-servername-cb)) 316 | (ssl-ctx-set-tlsext-servername-arg ctx sni)) 317 | (cffi:with-foreign-string (servername* servername) 318 | (ssl-set-tlsext-host-name handle servername*) 319 | (ensure-ssl-funcall stream handle #'ssl-connect handle))))) 320 | 321 | ;; fixme: free the context when errors happen in this function 322 | (defun make-ssl-client-stream 323 | (socket &key certificate key password (method 'ssl-v23-method) external-format 324 | close-callback (unwrap-stream-p t) servername) 325 | "Returns an SSL stream for the client socket descriptor SOCKET. 326 | CERTIFICATE is the path to a file containing the PEM-encoded certificate for 327 | your client. KEY is the path to the PEM-encoded key for the client, which 328 | may be associated with the passphrase PASSWORD." 329 | (ensure-initialized :method method) 330 | (let ((stream (make-instance 'ssl-stream 331 | :socket socket 332 | :close-callback close-callback)) 333 | (handle (ssl-new *ssl-global-context*))) 334 | (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p)) 335 | (ssl-set-connect-state handle) 336 | (with-pem-password (password) 337 | (install-key-and-cert handle key certificate)) 338 | (if servername 339 | (handle-servername stream handle servername) 340 | (ensure-ssl-funcall stream handle #'ssl-connect handle)) 341 | (when (ssl-check-verify-p) 342 | (ssl-stream-check-verify stream)) 343 | (handle-external-format stream external-format))) 344 | 345 | ;; fixme: free the context when errors happen in this function 346 | (defun make-ssl-server-stream 347 | (socket &key certificate key password (method 'ssl-v23-method) external-format 348 | close-callback (unwrap-stream-p t) 349 | (cipher-list *default-cipher-list*)) 350 | "Returns an SSL stream for the server socket descriptor SOCKET. 351 | CERTIFICATE is the path to a file containing the PEM-encoded certificate for 352 | your server. KEY is the path to the PEM-encoded key for the server, which 353 | may be associated with the passphrase PASSWORD." 354 | (ensure-initialized :method method) 355 | (let ((stream (make-instance 'ssl-server-stream 356 | :socket socket 357 | :close-callback close-callback 358 | :certificate certificate 359 | :key key)) 360 | (handle (ssl-new *ssl-global-context*))) 361 | (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p)) 362 | (ssl-set-accept-state handle) 363 | (when (zerop (ssl-set-cipher-list handle cipher-list)) 364 | (error 'ssl-error-initialize :reason "Can't set SSL cipher list")) 365 | (with-pem-password (password) 366 | (install-key-and-cert handle key certificate)) 367 | (ensure-ssl-funcall stream handle #'ssl-accept handle) 368 | (handle-external-format stream external-format))) 369 | 370 | #+openmcl 371 | (defmethod stream-deadline ((stream ccl::basic-stream)) 372 | (ccl::ioblock-deadline (ccl::stream-ioblock stream t))) 373 | #+openmcl 374 | (defmethod stream-deadline ((stream t)) 375 | nil) 376 | 377 | 378 | (defgeneric stream-fd (stream)) 379 | (defmethod stream-fd (stream) stream) 380 | 381 | #+sbcl 382 | (defmethod stream-fd ((stream sb-sys:fd-stream)) 383 | (sb-sys:fd-stream-fd stream)) 384 | 385 | #+cmu 386 | (defmethod stream-fd ((stream system:fd-stream)) 387 | (system:fd-stream-fd stream)) 388 | 389 | #+openmcl 390 | (defmethod stream-fd ((stream ccl::basic-stream)) 391 | (ccl::ioblock-device (ccl::stream-ioblock stream t))) 392 | 393 | #+clisp 394 | (defmethod stream-fd ((stream stream)) 395 | ;; sockets appear to be direct instances of STREAM 396 | (ext:stream-handles stream)) 397 | 398 | #+ecl 399 | (defmethod stream-fd ((stream two-way-stream)) 400 | (si:file-stream-fd (two-way-stream-input-stream stream))) 401 | -------------------------------------------------------------------------------- /ffi.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2001, 2003 Eric Marsden 2 | ;;; Copyright (C) 2005 David Lichteblau 3 | ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." 4 | ;;; 5 | ;;; See LICENSE for details. 6 | 7 | #+xcvb (module (:depends-on ("package" "conditions"))) 8 | 9 | (eval-when (:compile-toplevel) 10 | (declaim 11 | (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0)))) 12 | 13 | (in-package :cl+ssl) 14 | 15 | ;;; Global state 16 | ;;; 17 | (defvar *ssl-global-context* nil) 18 | (defvar *ssl-global-method* nil) 19 | (defvar *bio-lisp-method* nil) 20 | 21 | (defparameter *blockp* t) 22 | (defparameter *partial-read-p* nil) 23 | 24 | (defun ssl-initialized-p () 25 | (and *ssl-global-context* *ssl-global-method*)) 26 | 27 | 28 | ;;; Constants 29 | ;;; 30 | (defconstant +ssl-filetype-pem+ 1) 31 | (defconstant +ssl-filetype-asn1+ 2) 32 | (defconstant +ssl-filetype-default+ 3) 33 | 34 | (defconstant +SSL_CTRL_SET_SESS_CACHE_MODE+ 44) 35 | (defconstant +SSL_CTRL_MODE+ 33) 36 | 37 | (defconstant +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 2) 38 | 39 | (defconstant +RSA_F4+ #x10001) 40 | 41 | (defvar *tmp-rsa-key-512* nil) 42 | (defvar *tmp-rsa-key-1024* nil) 43 | (defvar *tmp-rsa-key-2048* nil) 44 | 45 | ;;; Misc 46 | ;;; 47 | (defmacro while (cond &body body) 48 | `(do () ((not ,cond)) ,@body)) 49 | 50 | 51 | ;;; Function definitions 52 | ;;; 53 | (declaim (inline ssl-write ssl-read ssl-connect ssl-accept)) 54 | 55 | (cffi:defctype ssl-method :pointer) 56 | (cffi:defctype ssl-ctx :pointer) 57 | (cffi:defctype ssl-pointer :pointer) 58 | 59 | (cffi:defcfun ("SSL_get_version" ssl-get-version) 60 | :string 61 | (ssl ssl-pointer)) 62 | (cffi:defcfun ("SSL_load_error_strings" ssl-load-error-strings) 63 | :void) 64 | (cffi:defcfun ("SSL_library_init" ssl-library-init) 65 | :int) 66 | ;; 67 | ;; We don't refer SSLv2_client_method as the default 68 | ;; builds of OpenSSL do not have it, due to insecurity 69 | ;; of the SSL v2 protocol (see https://www.openssl.org/docs/ssl/SSL_CTX_new.html 70 | ;; and https://github.com/cl-plus-ssl/cl-plus-ssl/issues/6) 71 | ;; 72 | ;; (cffi:defcfun ("SSLv2_client_method" ssl-v2-client-method) 73 | ;; ssl-method) 74 | (cffi:defcfun ("SSLv23_client_method" ssl-v23-client-method) 75 | ssl-method) 76 | (cffi:defcfun ("SSLv23_server_method" ssl-v23-server-method) 77 | ssl-method) 78 | (cffi:defcfun ("SSLv23_method" ssl-v23-method) 79 | ssl-method) 80 | (cffi:defcfun ("SSLv3_client_method" ssl-v3-client-method) 81 | ssl-method) 82 | (cffi:defcfun ("SSLv3_server_method" ssl-v3-server-method) 83 | ssl-method) 84 | (cffi:defcfun ("SSLv3_method" ssl-v3-method) 85 | ssl-method) 86 | (cffi:defcfun ("TLSv1_client_method" ssl-TLSv1-client-method) 87 | ssl-method) 88 | (cffi:defcfun ("TLSv1_server_method" ssl-TLSv1-server-method) 89 | ssl-method) 90 | (cffi:defcfun ("TLSv1_method" ssl-TLSv1-method) 91 | ssl-method) 92 | 93 | (cffi:defcfun ("SSL_CTX_new" ssl-ctx-new) 94 | ssl-ctx 95 | (method ssl-method)) 96 | (cffi:defcfun ("SSL_new" ssl-new) 97 | ssl-pointer 98 | (ctx ssl-ctx)) 99 | (cffi:defcfun ("SSL_get_fd" ssl-get-fd) 100 | :int 101 | (ssl ssl-pointer)) 102 | (cffi:defcfun ("SSL_set_fd" ssl-set-fd) 103 | :int 104 | (ssl ssl-pointer) 105 | (fd :int)) 106 | (cffi:defcfun ("SSL_set_bio" ssl-set-bio) 107 | :void 108 | (ssl ssl-pointer) 109 | (rbio :pointer) 110 | (wbio :pointer)) 111 | (cffi:defcfun ("SSL_get_error" ssl-get-error) 112 | :int 113 | (ssl ssl-pointer) 114 | (ret :int)) 115 | (cffi:defcfun ("SSL_set_connect_state" ssl-set-connect-state) 116 | :void 117 | (ssl ssl-pointer)) 118 | (cffi:defcfun ("SSL_set_accept_state" ssl-set-accept-state) 119 | :void 120 | (ssl ssl-pointer)) 121 | (cffi:defcfun ("SSL_connect" ssl-connect) 122 | :int 123 | (ssl ssl-pointer)) 124 | (cffi:defcfun ("SSL_accept" ssl-accept) 125 | :int 126 | (ssl ssl-pointer)) 127 | (cffi:defcfun ("SSL_write" ssl-write) 128 | :int 129 | (ssl ssl-pointer) 130 | (buf :pointer) 131 | (num :int)) 132 | (cffi:defcfun ("SSL_read" ssl-read) 133 | :int 134 | (ssl ssl-pointer) 135 | (buf :pointer) 136 | (num :int)) 137 | (cffi:defcfun ("SSL_shutdown" ssh-shutdown) 138 | :void 139 | (ssl ssl-pointer)) 140 | (cffi:defcfun ("SSL_free" ssl-free) 141 | :void 142 | (ssl ssl-pointer)) 143 | (cffi:defcfun ("SSL_CTX_free" ssl-ctx-free) 144 | :void 145 | (ctx ssl-ctx)) 146 | (cffi:defcfun ("BIO_ctrl" bio-set-fd) 147 | :long 148 | (bio :pointer) 149 | (cmd :int) 150 | (larg :long) 151 | (parg :pointer)) 152 | (cffi:defcfun ("BIO_new_socket" bio-new-socket) 153 | :pointer 154 | (fd :int) 155 | (close-flag :int)) 156 | (cffi:defcfun ("BIO_new" bio-new) 157 | :pointer 158 | (method :pointer)) 159 | 160 | (cffi:defcfun ("ERR_get_error" err-get-error) 161 | :unsigned-long) 162 | (cffi:defcfun ("ERR_error_string" err-error-string) 163 | :string 164 | (e :unsigned-long) 165 | (buf :pointer)) 166 | 167 | (cffi:defcfun ("SSL_set_cipher_list" ssl-set-cipher-list) 168 | :int 169 | (ssl ssl-pointer) 170 | (str :string)) 171 | (cffi:defcfun ("SSL_use_RSAPrivateKey_file" ssl-use-rsa-privatekey-file) 172 | :int 173 | (ssl ssl-pointer) 174 | (str :string) 175 | ;; either +ssl-filetype-pem+ or +ssl-filetype-asn1+ 176 | (type :int)) 177 | (cffi:defcfun 178 | ("SSL_CTX_use_RSAPrivateKey_file" ssl-ctx-use-rsa-privatekey-file) 179 | :int 180 | (ctx ssl-ctx) 181 | (type :int)) 182 | (cffi:defcfun ("SSL_use_certificate_file" ssl-use-certificate-file) 183 | :int 184 | (ssl ssl-pointer) 185 | (str :string) 186 | (type :int)) 187 | (cffi:defcfun ("SSL_CTX_use_certificate_chain_file" ssl-ctx-use-certificate-chain-file) 188 | :int 189 | (ctx ssl-ctx) 190 | (str :string)) 191 | (cffi:defcfun ("SSL_CTX_load_verify_locations" ssl-ctx-load-verify-locations) 192 | :int 193 | (ctx ssl-ctx) 194 | (CAfile :string) 195 | (CApath :string)) 196 | (cffi:defcfun ("SSL_CTX_set_client_CA_list" ssl-ctx-set-client-ca-list) 197 | :void 198 | (ctx ssl-ctx) 199 | (list ssl-pointer)) 200 | (cffi:defcfun ("SSL_load_client_CA_file" ssl-load-client-ca-file) 201 | ssl-pointer 202 | (file :string)) 203 | 204 | (cffi:defcfun ("SSL_CTX_ctrl" ssl-ctx-ctrl) 205 | :long 206 | (ctx ssl-ctx) 207 | (cmd :int) 208 | (larg :long) 209 | (parg :pointer)) 210 | 211 | (cffi:defcfun ("SSL_CTX_callback_ctrl" ssl-ctx-callback-ctrl) 212 | :long 213 | (ctx ssl-ctx) 214 | (cmd :int) 215 | (fp :pointer)) 216 | 217 | (defconstant +SSL_TLSEXT_ERR_OK+ 0) 218 | (defconstant +SSL_CTRL_SET_TLSEXT_SERVERNAME_CB+ 53) 219 | (defconstant +SSL_CTRL_SET_TLSEXT_SERVERNAME_ARG+ 54) 220 | (defconstant +SSL_CTRL_SET_TLSEXT_HOSTNAME+ 55) 221 | (defconstant +TLSEXT_NAMETYPE_host_name+ 0) 222 | 223 | (defmacro ssl-ctx-set-tlsext-servername-callback (ctx cb) 224 | `(ssl-ctx-callback-ctrl ,ctx +SSL_CTRL_SET_TLSEXT_SERVERNAME_CB+ ,cb)) 225 | 226 | (defmacro ssl-ctx-set-tlsext-servername-arg (ctx arg) 227 | `(ssl-ctx-ctrl ,ctx +SSL_CTRL_SET_TLSEXT_SERVERNAME_ARG+ 0 ,arg)) 228 | 229 | (defmacro ssl-set-tlsext-host-name (s name) 230 | `(ssl-ctrl ,s +SSL_CTRL_SET_TLSEXT_HOSTNAME+ +TLSEXT_NAMETYPE_host_name+ ,name)) 231 | 232 | (cffi:defcstruct tlsextctx 233 | (biodebug :pointer) 234 | (ack :int)) 235 | 236 | (cffi:defcfun ("SSL_get_servername" ssl-get-servername) 237 | (:pointer :char) 238 | (s ssl-pointer) 239 | (type :int)) 240 | 241 | (cffi:defcfun ("SSL_get_servername_type" ssl-get-servername-type) 242 | :int 243 | (s ssl-pointer)) 244 | 245 | (cffi:defcfun ("SSL_ctrl" ssl-ctrl) 246 | :long 247 | (s ssl-pointer) 248 | (cmd :int) 249 | (larg :long) 250 | (parg :pointer)) 251 | 252 | (defconstant +SSL_CTRL_GET_SESSION_REUSED+ 8) 253 | 254 | (defmacro ssl-session-reused (s) 255 | `(ssl-ctrl ,s +SSL_CTRL_GET_SESSION_REUSED+ 0 (cffi:null-pointer))) 256 | 257 | (defconstant +TLSEXT_NAMETYPE_host_name+ 0) 258 | 259 | (cffi:defcallback lisp-ssl-servername-cb :int 260 | ((s ssl-pointer) 261 | (ad (:pointer :int)) 262 | (arg :pointer)) 263 | (declare (ignore ad)) 264 | (cffi:with-foreign-slots ((ack) arg (:struct tlsextctx)) 265 | (let ((hn (ssl-get-servername s +TLSEXT_NAMETYPE_host_name+))) 266 | (when (/= (ssl-get-servername-type s) -1) 267 | (setf ack (if (and (zerop (ssl-session-reused s)) 268 | (not (cffi:null-pointer-p hn))) 1 0))) 269 | +SSL_TLSEXT_ERR_OK+))) 270 | 271 | (cffi:defcfun ("SSL_CTX_set_default_passwd_cb" ssl-ctx-set-default-passwd-cb) 272 | :void 273 | (ctx ssl-ctx) 274 | (pem_passwd_cb :pointer)) 275 | 276 | (cffi:defcfun ("CRYPTO_num_locks" crypto-num-locks) :int) 277 | (cffi:defcfun ("CRYPTO_set_locking_callback" crypto-set-locking-callback) 278 | :void 279 | (fun :pointer)) 280 | (cffi:defcfun ("CRYPTO_set_id_callback" crypto-set-id-callback) 281 | :void 282 | (fun :pointer)) 283 | 284 | (cffi:defcfun ("RAND_seed" rand-seed) 285 | :void 286 | (buf :pointer) 287 | (num :int)) 288 | (cffi:defcfun ("RAND_bytes" rand-bytes) 289 | :int 290 | (buf :pointer) 291 | (num :int)) 292 | 293 | (cffi:defcfun ("SSL_CTX_set_verify_depth" ssl-ctx-set-verify-depth) 294 | :void 295 | (ctx :pointer) 296 | (depth :int)) 297 | 298 | (cffi:defcfun ("SSL_get_verify_result" ssl-get-verify-result) 299 | :long 300 | (ssl ssl-pointer)) 301 | 302 | (cffi:defcfun ("SSL_get_peer_certificate" ssl-get-peer-certificate) 303 | :pointer 304 | (ssl ssl-pointer)) 305 | 306 | (cffi:defcfun ("X509_free" x509-free) 307 | :void 308 | (x509 :pointer)) 309 | 310 | (cffi:defcfun ("X509_NAME_oneline" x509-name-oneline) 311 | :pointer 312 | (x509-name :pointer) 313 | (buf :pointer) 314 | (size :int)) 315 | 316 | (cffi:defcfun ("X509_get_issuer_name" x509-get-issuer-name) 317 | :pointer ; *X509_NAME 318 | (x509 :pointer)) 319 | 320 | (cffi:defcfun ("X509_get_subject_name" x509-get-subject-name) 321 | :pointer ; *X509_NAME 322 | (x509 :pointer)) 323 | 324 | (cffi:defcfun ("SSL_CTX_set_default_verify_paths" ssl-ctx-set-default-verify-paths) 325 | :int 326 | (ctx :pointer)) 327 | 328 | (cffi:defcfun ("RSA_generate_key" rsa-generate-key) 329 | :pointer 330 | (num :int) 331 | (e :unsigned-long) 332 | (callback :pointer) 333 | (opt :pointer)) 334 | 335 | (cffi:defcfun ("RSA_free" rsa-free) 336 | :void 337 | (rsa :pointer)) 338 | 339 | (cffi:defcfun ("SSL_CTX_set_tmp_rsa_callback" ssl-ctx-set-tmp-rsa-callback) 340 | :pointer 341 | (ctx :pointer) 342 | (callback :pointer)) 343 | 344 | (cffi:defcallback need-tmp-rsa-callback :pointer ((ssl :pointer) (export-p :int) (key-length :int)) 345 | (declare (ignore ssl export-p)) 346 | (flet ((rsa-key (length) 347 | (rsa-generate-key length 348 | +RSA_F4+ 349 | (cffi:null-pointer) 350 | (cffi:null-pointer)))) 351 | (cond ((= key-length 512) 352 | (unless *tmp-rsa-key-512* 353 | (setf *tmp-rsa-key-512* (rsa-key key-length))) 354 | *tmp-rsa-key-512*) 355 | ((= key-length 1024) 356 | (unless *tmp-rsa-key-1024* 357 | (setf *tmp-rsa-key-1024* (rsa-key key-length))) 358 | *tmp-rsa-key-1024*) 359 | (t 360 | (unless *tmp-rsa-key-2048* 361 | (setf *tmp-rsa-key-2048* (rsa-key key-length))) 362 | *tmp-rsa-key-2048*)))) 363 | 364 | ;;; Funcall wrapper 365 | ;;; 366 | (defvar *socket*) 367 | 368 | (declaim (inline ensure-ssl-funcall)) 369 | (defun ensure-ssl-funcall (stream handle func &rest args) 370 | (loop 371 | (let ((nbytes 372 | (let ((*socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks 373 | (apply func args)))) 374 | (when (plusp nbytes) 375 | (return nbytes)) 376 | (let ((error (ssl-get-error handle nbytes))) 377 | (case error 378 | (#.+ssl-error-want-read+ 379 | (input-wait stream 380 | (ssl-get-fd handle) 381 | (ssl-stream-deadline stream))) 382 | (#.+ssl-error-want-write+ 383 | (output-wait stream 384 | (ssl-get-fd handle) 385 | (ssl-stream-deadline stream))) 386 | (t 387 | (ssl-signal-error handle func error nbytes))))))) 388 | 389 | (declaim (inline nonblocking-ssl-funcall)) 390 | (defun nonblocking-ssl-funcall (stream handle func &rest args) 391 | (loop 392 | (let ((nbytes 393 | (let ((*socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks 394 | (apply func args)))) 395 | (when (plusp nbytes) 396 | (return nbytes)) 397 | (let ((error (ssl-get-error handle nbytes))) 398 | (case error 399 | ((#.+ssl-error-want-read+ #.+ssl-error-want-write+) 400 | (return nbytes)) 401 | (t 402 | (ssl-signal-error handle func error nbytes))))))) 403 | 404 | 405 | ;;; Waiting for output to be possible 406 | 407 | #+clozure-common-lisp 408 | (defun milliseconds-until-deadline (deadline stream) 409 | (let* ((now (get-internal-real-time))) 410 | (if (> now deadline) 411 | (error 'ccl::communication-deadline-expired :stream stream) 412 | (values 413 | (round (- deadline now) (/ internal-time-units-per-second 1000)))))) 414 | 415 | #+clozure-common-lisp 416 | (defun output-wait (stream fd deadline) 417 | (unless deadline 418 | (setf deadline (stream-deadline (ssl-stream-socket stream)))) 419 | (let* ((timeout 420 | (if deadline 421 | (milliseconds-until-deadline deadline stream) 422 | nil))) 423 | (multiple-value-bind (win timedout error) 424 | (ccl::process-output-wait fd timeout) 425 | (unless win 426 | (if timedout 427 | (error 'ccl::communication-deadline-expired :stream stream) 428 | (ccl::stream-io-error stream (- error) "write")))))) 429 | 430 | #+sbcl 431 | (defun output-wait (stream fd deadline) 432 | (declare (ignore stream)) 433 | (let ((timeout 434 | ;; *deadline* is handled by wait-until-fd-usable automatically, 435 | ;; but we need to turn a user-specified deadline into a timeout 436 | (when deadline 437 | (/ (- deadline (get-internal-real-time)) 438 | internal-time-units-per-second)))) 439 | (sb-sys:wait-until-fd-usable fd :output timeout))) 440 | 441 | #-(or clozure-common-lisp sbcl) 442 | (defun output-wait (stream fd deadline) 443 | (declare (ignore stream fd deadline)) 444 | ;; This situation means that the lisp set our fd to non-blocking mode, 445 | ;; and streams.lisp didn't know how to undo that. 446 | (warn "non-blocking stream encountered unexpectedly")) 447 | 448 | 449 | ;;; Waiting for input to be possible 450 | 451 | #+clozure-common-lisp 452 | (defun input-wait (stream fd deadline) 453 | (unless deadline 454 | (setf deadline (stream-deadline (ssl-stream-socket stream)))) 455 | (let* ((timeout 456 | (if deadline 457 | (milliseconds-until-deadline deadline stream) 458 | nil))) 459 | (multiple-value-bind (win timedout error) 460 | (ccl::process-input-wait fd timeout) 461 | (unless win 462 | (if timedout 463 | (error 'ccl::communication-deadline-expired :stream stream) 464 | (ccl::stream-io-error stream (- error) "read")))))) 465 | 466 | #+sbcl 467 | (defun input-wait (stream fd deadline) 468 | (declare (ignore stream)) 469 | (let ((timeout 470 | ;; *deadline* is handled by wait-until-fd-usable automatically, 471 | ;; but we need to turn a user-specified deadline into a timeout 472 | (when deadline 473 | (/ (- deadline (get-internal-real-time)) 474 | internal-time-units-per-second)))) 475 | (sb-sys:wait-until-fd-usable fd :input timeout))) 476 | 477 | #-(or clozure-common-lisp sbcl) 478 | (defun input-wait (stream fd deadline) 479 | (declare (ignore stream fd deadline)) 480 | ;; This situation means that the lisp set our fd to non-blocking mode, 481 | ;; and streams.lisp didn't know how to undo that. 482 | (warn "non-blocking stream encountered unexpectedly")) 483 | 484 | 485 | ;;; Encrypted PEM files support 486 | ;;; 487 | 488 | ;; based on http://www.openssl.org/docs/ssl/SSL_CTX_set_default_passwd_cb.html 489 | 490 | (defvar *pem-password* "" 491 | "The callback registered with SSL_CTX_set_default_passwd_cb 492 | will use this value.") 493 | 494 | ;; The callback itself 495 | (cffi:defcallback pem-password-callback :int 496 | ((buf :pointer) (size :int) (rwflag :int) (unused :pointer)) 497 | (declare (ignore rwflag unused)) 498 | (let* ((password-str (coerce *pem-password* 'base-string)) 499 | (tmp (cffi:foreign-string-alloc password-str))) 500 | (cffi:foreign-funcall "strncpy" 501 | :pointer buf 502 | :pointer tmp 503 | :int size) 504 | (cffi:foreign-string-free tmp) 505 | (setf (cffi:mem-ref buf :char (1- size)) 0) 506 | (cffi:foreign-funcall "strlen" :pointer buf :int))) 507 | 508 | ;; The macro to be used by other code to provide password 509 | ;; when loading PEM file. 510 | (defmacro with-pem-password ((password) &body body) 511 | `(let ((*pem-password* (or ,password ""))) 512 | ,@body)) 513 | 514 | 515 | ;;; Initialization 516 | ;;; 517 | 518 | (defun init-prng (seed-byte-sequence) 519 | (let* ((length (length seed-byte-sequence)) 520 | (buf (cffi-sys::make-shareable-byte-vector length))) 521 | (dotimes (i length) 522 | (setf (elt buf i) (elt seed-byte-sequence i))) 523 | (cffi-sys::with-pointer-to-vector-data (ptr buf) 524 | (rand-seed ptr length)))) 525 | 526 | (defun ssl-ctx-set-session-cache-mode (ctx mode) 527 | (ssl-ctx-ctrl ctx +SSL_CTRL_SET_SESS_CACHE_MODE+ mode (cffi:null-pointer))) 528 | 529 | (defvar *locks*) 530 | (defconstant +CRYPTO-LOCK+ 1) 531 | (defconstant +CRYPTO-UNLOCK+ 2) 532 | (defconstant +CRYPTO-READ+ 4) 533 | (defconstant +CRYPTO-WRITE+ 8) 534 | 535 | ;; zzz as of early 2011, bxthreads is totally broken on SBCL wrt. explicit 536 | ;; locking of recursive locks. with-recursive-lock works, but acquire/release 537 | ;; don't. Hence we use non-recursize locks here (but can use a recursive 538 | ;; lock for the global lock). 539 | 540 | (cffi:defcallback locking-callback :void 541 | ((mode :int) 542 | (n :int) 543 | (file :string) 544 | (line :int)) 545 | (declare (ignore file line)) 546 | ;; (assert (logtest mode (logior +CRYPTO-READ+ +CRYPTO-WRITE+))) 547 | (let ((lock (elt *locks* n))) 548 | (cond 549 | ((logtest mode +CRYPTO-LOCK+) 550 | (bt:acquire-lock lock)) 551 | ((logtest mode +CRYPTO-UNLOCK+) 552 | (bt:release-lock lock)) 553 | (t 554 | (error "fell through"))))) 555 | 556 | (defvar *threads* (trivial-garbage:make-weak-hash-table :weakness :key)) 557 | (defvar *thread-counter* 0) 558 | 559 | (defparameter *global-lock* 560 | (bordeaux-threads:make-recursive-lock "SSL initialization")) 561 | 562 | ;; zzz BUG: On a 32-bit system and under non-trivial load, this counter 563 | ;; is likely to wrap in less than a year. 564 | (cffi:defcallback threadid-callback :unsigned-long () 565 | (bordeaux-threads:with-recursive-lock-held (*global-lock*) 566 | (let ((self (bt:current-thread))) 567 | (or (gethash self *threads*) 568 | (setf (gethash self *threads*) 569 | (incf *thread-counter*)))))) 570 | 571 | (defvar *ssl-check-verify-p* :unspecified) 572 | 573 | (defun initialize (&key (method 'ssl-v23-method) rand-seed) 574 | (setf *locks* (loop 575 | repeat (crypto-num-locks) 576 | collect (bt:make-lock))) 577 | (crypto-set-locking-callback (cffi:callback locking-callback)) 578 | (crypto-set-id-callback (cffi:callback threadid-callback)) 579 | (setf *bio-lisp-method* (make-bio-lisp-method)) 580 | (ssl-load-error-strings) 581 | (ssl-library-init) 582 | (when rand-seed 583 | (init-prng rand-seed)) 584 | (setf *ssl-check-verify-p* :unspecified) 585 | (setf *ssl-global-method* (funcall method)) 586 | (setf *ssl-global-context* (ssl-ctx-new *ssl-global-method*)) 587 | (ssl-ctx-set-session-cache-mode *ssl-global-context* 3) 588 | (ssl-ctx-set-default-passwd-cb *ssl-global-context* 589 | (cffi:callback pem-password-callback)) 590 | (ssl-ctx-set-tmp-rsa-callback *ssl-global-context* 591 | (cffi:callback need-tmp-rsa-callback))) 592 | 593 | (defun ensure-initialized (&key (method 'ssl-v23-method) (rand-seed nil)) 594 | "In most cases you do *not* need to call this function, because it 595 | is called automatically by all other functions. The only reason to 596 | call it explicitly is to supply the RAND-SEED parameter. In this case 597 | do it before calling any other functions. 598 | 599 | Just leave the default value for the METHOD parameter. 600 | 601 | RAND-SEED is an octet sequence to initialize OpenSSL random number generator. 602 | On many platforms, including Linux and Windows, it may be leaved NIL (default), 603 | because OpenSSL initializes the random number generator from OS specific service. 604 | But for example on Solaris it may be necessary to supply this value. 605 | The minimum length required by OpenSSL is 128 bits. 606 | See ttp://www.openssl.org/support/faq.html#USER1 for details. 607 | 608 | Hint: do not use Common Lisp RANDOM function to generate the RAND-SEED, 609 | because the function usually returns predictable values." 610 | (bordeaux-threads:with-recursive-lock-held (*global-lock*) 611 | (unless (ssl-initialized-p) 612 | (initialize :method method :rand-seed rand-seed)) 613 | (unless *bio-lisp-method* 614 | (setf *bio-lisp-method* (make-bio-lisp-method))))) 615 | 616 | (defun use-certificate-chain-file (certificate-chain-file) 617 | "Loads a PEM encoded certificate chain file CERTIFICATE-CHAIN-FILE 618 | and adds the chain to global context. The certificates must be sorted 619 | starting with the subject's certificate (actual client or server certificate), 620 | followed by intermediate CA certificates if applicable, and ending at 621 | the highest level (root) CA. Note: the RELOAD function clears the global 622 | context and in particular the loaded certificate chain." 623 | (ensure-initialized) 624 | (ssl-ctx-use-certificate-chain-file *ssl-global-context* certificate-chain-file)) 625 | 626 | (defun reload () 627 | (cffi:load-foreign-library 'libssl) 628 | (cffi:load-foreign-library 'libeay32) 629 | (setf *ssl-global-context* nil) 630 | (setf *ssl-global-method* nil) 631 | (setf *tmp-rsa-key-512* nil) 632 | (setf *tmp-rsa-key-1024* nil)) 633 | --------------------------------------------------------------------------------