pax_global_header00006660000000000000000000000064131154306070014512gustar00rootroot0000000000000052 comment=50a857368a5fd9d54c02ff2bcb50f406a1b81250 cl+ssl-20170630-git/000077500000000000000000000000001311543060700137325ustar00rootroot00000000000000cl+ssl-20170630-git/.gitignore000066400000000000000000000000121311543060700157130ustar00rootroot00000000000000*~ \#* .#*cl+ssl-20170630-git/.travis.yml000066400000000000000000000025501311543060700160450ustar00rootroot00000000000000language: common-lisp sudo: false # lets try new infrastructure env: global: - PATH=~/.roswell/bin:$PATH - ROSWELL_BRANCH=release - ROSWELL_INSTALL_DIR=$HOME/.roswell - COVERAGE_EXCLUDE=test matrix: - LISP=sbcl-bin COVERALLS=true - LISP=ccl-bin # CLISP is disabled because it can't load bordeaux-treads which require ASDF >= 3.1 # Example log: https://travis-ci.org/cl-plus-ssl/cl-plus-ssl/jobs/181539210 # (As a workaround we could try to download ASDF 3 ourselves) # - LISP=clisp - LISP=ecl install: - curl -L https://raw.githubusercontent.com/snmsts/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh # cache: # directories: # - $HOME/.roswell # - $HOME/.config/common-lisp script: - "ros -e '(progn (format t \"(lisp-implementation-type): ~A~%\" (lisp-implementation-type)) (format t \"(lisp-implementation-version): ~A~%\" (lisp-implementation-version)) (format t \"*features*: ~A~%\" *features*) (format t \"(asdf:asdf-version): ~A~%\" (asdf:asdf-version)))' -e '(ql:quickload :cl+ssl.test)' -e '(let ((results (coveralls:with-coveralls (:exclude \"test\") (5am:run :cl+ssl)))) (5am:explain! results) (unless (5am:results-status results) (uiop:quit 1)))'" cl+ssl-20170630-git/LICENSE000066400000000000000000000027311311543060700147420ustar00rootroot00000000000000Copyright (C) 2001, 2003 Eric Marsden Copyright (C) ???? Jochen Schmidt Copyright (C) 2005 David Lichteblau Copyright (C) 2007 Pixel // pinterface * License first changed by Eric Marsden, Jochen Schmidt, and David Lichteblau from plain LGPL to Lisp-LGPL in December 2005. * License then changed by Eric Marsden, Jochen Schmidt, and David Lichteblau from Lisp-LGPL to MIT-style in January 2007. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. cl+ssl-20170630-git/Makefile000066400000000000000000000001041311543060700153650ustar00rootroot00000000000000.PHONY: clean clean: rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl cl+ssl-20170630-git/README.md000066400000000000000000000003061311543060700152100ustar00rootroot00000000000000[![Build Status](https://travis-ci.org/cl-plus-ssl/cl-plus-ssl.svg?branch=master)](https://travis-ci.org/cl-plus-ssl/cl-plus-ssl) See project homepage: http://common-lisp.net/project/cl-plus-ssl/ cl+ssl-20170630-git/build.xcvb000066400000000000000000000013261311543060700157170ustar00rootroot00000000000000;;; -*- mode: lisp -*- ;;; ;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; Copyright (C) 2007 Pixel // pinterface ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. #+xcvb (module (:fullname "cl+ssl" :depends-on ("src/package" "src/reload" "src/conditions" "src/ffi" "src/ffi-buffer-all" (:cond ((:featurep :clisp) "src/ffi-buffer-clisp") ((:featurep (:not :clisp)) "src/ffi-buffer")) "src/streams" "src/bio" "src/random" "src/context") :build-depends-on ("flexi-streams" "trivial-gray-streams" "cffi") :supersedes-asdf ("cl+ssl"))) cl+ssl-20170630-git/cl+ssl.asd000066400000000000000000000025741311543060700156260ustar00rootroot00000000000000;;; -*- mode: lisp -*- ;;; ;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; Copyright (C) 2007 Pixel // pinterface ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. (defpackage :cl+ssl-system (:use :cl :asdf)) (in-package :cl+ssl-system) (defsystem :cl+ssl :description "Common Lisp interface to OpenSSL." :license "MIT" :author "Eric Marsden, Jochen Schmidt, David Lichteblau" :depends-on (:cffi :trivial-gray-streams :flexi-streams #+sbcl :sb-posix :bordeaux-threads :trivial-garbage :uiop) :serial t :components ((:module "src" :serial t :components ((:file "package") (:file "reload") (:file "conditions") (:file "ffi") (:file "ffi-buffer-all") #-clisp (:file "ffi-buffer") #+clisp (:file "ffi-buffer-clisp") (:file "streams") (:file "bio") (:file "random") (:file "context"))))) (defsystem :openssl-1.1.0 :description "FFI bindings to API introduced in OpenSSL 1.1.0" :license "MIT" :author "Anton Vodonosov" :depends-on (:cffi) :serial t :components ((:module "src" :serial t :components ((:file "ffi-1.1.0"))))) cl+ssl-20170630-git/cl+ssl.test.asd000066400000000000000000000012511311543060700165730ustar00rootroot00000000000000;;; -*- mode: lisp -*- ;;; ;;; Copyright (C) 2015 Ilya Khaprov ;;; ;;; See LICENSE for details. (defpackage :cl+ssl.test-system (:use :cl :asdf)) (in-package :cl+ssl.test-system) (asdf:defsystem :cl+ssl.test :version "0.1" :description "CL+SSL test suite" :maintainer "Ilya Khaprov " :author "Ilya Khaprov " :licence "MIT" :depends-on (:fiveam :cl-coveralls :cl+ssl :usocket) :serial t :components ((:module "test" :serial t :components ((:file "package") (:file "dummy") (:file "sni"))))) cl+ssl-20170630-git/example.lisp000066400000000000000000000070341311543060700162620ustar00rootroot00000000000000;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. #| (load "example.lisp") (ssl-test::test-https-client "www.google.com") (ssl-test::test-https-server) |# (defpackage :ssl-test (:use :cl)) (in-package :ssl-test) (eval-when (:compile-toplevel :load-toplevel :execute) (asdf:operate 'asdf:load-op :trivial-sockets)) (defun read-line-crlf (stream &optional eof-error-p) (let ((s (make-string-output-stream))) (loop for empty = t then nil for c = (read-char stream eof-error-p nil) while (and c (not (eql c #\return))) do (unless (eql c #\newline) (write-char c s)) finally (return (if empty nil (get-output-stream-string s)))))) (defun test-nntps-client (&optional (host "snews.gmane.org") (port 563)) (let* ((fd (trivial-sockets:open-stream host port :element-type '(unsigned-byte 8))) (nntps (cl+ssl:make-ssl-client-stream fd :external-format '(:iso-8859-1 :eol-style :lf)))) (format t "NNTPS> ~A~%" (read-line-crlf nntps)) (write-line "HELP" nntps) (force-output nntps) (loop :for line = (read-line-crlf nntps nil) :until (string-equal "." line) :do (format t "NNTPS> ~A~%" line)))) ;; open an HTTPS connection to a secure web server and make a ;; HEAD request (defun test-https-client (host &optional (port 443)) (let* ((deadline (+ (get-internal-real-time) (* 3 internal-time-units-per-second))) (socket (ccl:make-socket :address-family :internet :connect :active :type :stream :remote-host host :remote-port port ;; :local-host (resolve-hostname local-host) ;; :local-port local-port :deadline deadline)) (https (progn (cl+ssl:make-ssl-client-stream socket :unwrap-stream-p t :external-format '(:iso-8859-1 :eol-style :lf))))) (unwind-protect (progn (format https "GET / HTTP/1.0~%Host: ~a~%~%" host) (force-output https) (loop :for line = (read-line-crlf https nil) :while line :do (format t "HTTPS> ~a~%" line))) (close https)))) ;; start a simple HTTPS server. See the mod_ssl documentation at ;; for information on generating the ;; server certificate and key ;; ;; You can stress-test the server with ;; ;; siege -c 10 -u https://host:8080/foobar ;; (defun test-https-server (&key (port 8080) (cert "/home/david/newcert.pem") (key "/home/david/newkey.pem")) (format t "~&SSL server listening on port ~d~%" port) (trivial-sockets:with-server (server (:port port)) (loop (let* ((socket (trivial-sockets:accept-connection server :element-type '(unsigned-byte 8))) (client (cl+ssl:make-ssl-server-stream socket :external-format '(:iso-8859-1 :eol-style :lf) :certificate cert :key key))) (unwind-protect (progn (loop :for line = (read-line-crlf client nil) :while (> (length line) 1) :do (format t "HTTPS> ~a~%" line)) (format client "HTTP/1.0 200 OK~%") (format client "Server: SSL-CMUCL/1.1~%") (format client "Content-Type: text/plain~%") (terpri client) (format client "G'day at ~A!~%" (multiple-value-list (get-decoded-time))) (format client "CL+SSL running in ~A ~A~%" (lisp-implementation-type) (lisp-implementation-version))) (close client)))))) cl+ssl-20170630-git/index.css000066400000000000000000000016721311543060700155610ustar00rootroot00000000000000div.sidebar { float: right; background-color: #eeeeee; border: 2pt solid black; margin: 0em 2pt 1em 2em; min-width: 15%; padding: 0pt 5pt 5pt 5pt; } div.sidebar ul { padding: 0pt 0pt 0pt 1em; margin: 0 0 1em; } body { color: #000000; background-color: #ffffff; margin-right: 0pt; margin-bottom: 10%; padding-left: 30px; } h1,h2 { margin-left: -30px; } h3 { margin-top: 2em; margin-left: -20px; } th { background-color: darkred; color: white; text-align: left; } pre { background-color: #eeeeee; border: solid 1px #d0d0d0; padding: 1em; margin-right: 10%; } .def { background-color: #eeeeee; width: 90%; font-weight: bold; border: solid 1px #d0d0d0; padding: 3px; } .nomargin { margin-bottom: 0; margin-top: 0; } .working { background-color: #60c060; } .broken { background-color: #ff6060; } .incomplete { background-color: #ffff60; } .unknown { background-color: #cccccc; } cl+ssl-20170630-git/index.html000066400000000000000000000402131311543060700157270ustar00rootroot00000000000000 CL+SSL

CL+SSL

A Common Lisp interface to OpenSSL.

About

This library is a fork of SSL-CMUCL. The original SSL-CMUCL source code was written by Eric Marsden and includes contributions by Jochen Schmidt. Development into CL+SSL was done by David Lichteblau. License: MIT-style.

Distinguishing features: CL+SSL is portable code based on CFFI and gray streams. It defines its own libssl BIO method, so that SSL I/O can be written over portable Lisp streams instead of bypassing the streams and sending data over Unix file descriptors directly. (But the traditional approach is still used if possible.)

Download

The library is available via Quicklisp.

The Git repository: https://github.com/cl-plus-ssl/cl-plus-ssl.

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

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

OpenSSL binaries for Windows may be found at http://www.slproweb.com/products/Win32OpenSSL.html (slproweb.com is a 3rd party; if you have questions about the OpenSSL installer they provide, please ask in the mailing list specified on the linked page).

API functions

Function CL+SSL:ENSURE-INITIALIZED (&key (method 'ssl-v23-method) (rand-seed nil))
In most cases you do not need to call this function, because it is called automatically. The only reason to call it explicitly is to supply the rand-seed parameter. In this case do it before calling any other functions.

Keyword arguments:

method. Just leave its default value.

rand-seed is an octet sequence to initialize OpenSSL random number generator. On many platforms, including Linux and Windows, it may be leaved NIL (default), because OpenSSL initializes the random number generator from OS specific service. But for example on Solaris it may be necessary to supply this value. The minimum length required by OpenSSL is 128 bits. See here http://www.openssl.org/support/faq.html#USER1 for the details.

Hint: do not use Common Lisp RANDOM function to generate the rand-seed, because the function usually returns predictable values. 

Function CL+SSL:MAKE-CONTEXT (&key (method (ssl-v23-method))
                                                                               (disabled-protocols)
                                                                               (options (list +SSL-OP-ALL+))
                                                                               (session-cache-mode +ssl-sess-cache-server+)
                                                                               (verify-location :default)
                                                                               (verify-depth 100)
                                                                               (verify-mode +ssl-verify-peer+)
                                                                               (verify-callback nil verify-callback-supplied-p)
                                                                               (cipher-list +default-cipher-list+)
                                                                               (pem-password-callback 'pem-password-callback))

Creates a new SSL_CTX using SSL_CTX_new and initializes it according to the specified parameters. After you're done using the context, don't forget to free it using ssl-ctx-free.

Exceptions:

ssl-error-initialize. When underlying SSL_CTX_new fails.

Keyword arguments:

method. Specifies which supported SSL/TLS to use. Defaults to ssl-v23-method

disabled-protocols. List of +SSL-OP-NO-* constants. Denotes disabled SSL/TLS versions. When method not specified defaults to (list +SSL-OP-NO-SSLv2+ +SSL-OP-NO-SSLv3+)

options. SSL context options list. Defaults to (list +SSL-OP-ALL+)

session-cache-mode. Enable/Disable session caching. Defaults to +SSL-SESS-CACHE-SERVER+

verify-location. Location(s) to load CA from. Possible values

  • :default OpenSSL default directory and file will be loaded
  • :default-file OpenSSL default file will be loaded
  • :default-dir OpenSSL default directory will be loaded
  • STRING Directory or file path to be loaded
  • PATHNAME Directory or file path to be loaded
  • (LIST (or STRING PATHNAME)) List of directories or files to be loaded

verify-depth. Sets the maximum depth for the certificate chain verification that shall be allowed for context. Defaults to 100.

verify-mode. Sets the verification flags for context to be mode. Available flags

  • +SSL-VERIFY-NONE+
  • +SSL-VERIFY-PEER+
  • +SSL-VERIFY-FAIL-IF-NO-PEER-CERT+
  • +SSL-VERIFY-CLIENT-ONCE+
Defaults to +VERIFY-PEER+

verify-callback. The verify-callback is used to control the behaviour when the +SSL-VERIFY-PEER+ flag is set.
Please note: this must be CFFI callback i.e. defined as (defcallback :int ((ok :int) (ctx :pointer)) .. ).
Defaults to verify-peer-callback which converts chain errors to ssl-error-verify.

cipher-list. Sets the list of available ciphers for context. Possible values described here.
Default is expected to change overtime to provide highest security level. Do not rely on its exact value.

pem-password-callback. Sets the default password callback called when loading/storing a PEM certificate with encryption.
Please note: this must be CFFI callback i.e. defined as (cffi:defcallback :int ((buf :pointer) (size :int) (rwflag :int) (unused :pointer)) .. ).
Defaults to pem-password-callback which simply uses password provided by with-pem-password.

Function CL+SSL:SSL-CTX-FREE (context)
Plain FFI binding for SSL_CTX_free.

Macro CL+SSL:WITH-GLOBAL-CONTEXT ((context &key :auto-free-p) &body body)
Executes body with *ssl-global-context* bound to context.
If auto-free-p is true the context is freed using ssl-ctx-free before exit.

Function CL+SSL:MAKE-SSL-CLIENT-STREAM (fd-or-stream &key external-format certificate key password close-callback (unwrap-streams-p t) hostname)

Function CL+SSL:MAKE-SSL-SERVER-STREAM (fd-or-stream &key external-format certificate key password close-callback (unwrap-streams-p t))
Return an SSL stream for the client (server) socket fd-or-stream. All reads and writes to this stream will be pushed through the OpenSSL library.

Keyword arguments:

If fd-or-stream is a lisp stream, the SSL stream will close it automatically. File descriptors are not closed automatically. However, if close-callback is non-nil, it will be called with zero arguments when the SSL stream is closed.

If unwrap-stream-p is true (the default), a stream for a file descriptor will be replaced by that file descriptor automatically. This is similar to passing the result of stream-fd as an argument, except that a deadline associated with the stream object will be taken into account, and that the stream will be closed automatically. As with file descriptor arguments, no I/O will actually be done on the stream object.

certificate is the path to a file containing the PEM-encoded certificate.

key is the path to the PEM-encoded key, which may be associated with the passphrase password.

If external-format is nil (the default), a plain (unsigned-byte 8) SSL stream is returned. With a non-null external-format, a flexi-stream capable of character I/O will be returned instead, with the specified value as its initial external format.

hostname if specified, will be sent by client during TLS negotiation, according to the Server Name Indication (SNI) extension to the TLS. When server handles several domain names, this extension enables the server to choose certificate for right domain.

Function CL+SSL:USE-CERTIFICATE-CHAIN-FILE (certificate-chain-file)
Loads a PEM encoded certificate chain file certificate-chain-file and adds the chain to global context. The certificates must be sorted starting with the subject's certificate (actual client or server certificate), followed by intermediate CA certificates if applicable, and ending at the highest level (root) CA.

Note: the RELOAD function clears the global context and in particular the loaded certificate chain.

Function CL+SSL:RELOAD ()
Reload libssl. Call this function after restarting a Lisp core with CL+SSL dumped into it on Lisp implementations that do not reload shared libraries automatically.

Function CL+SSL:STREAM-FD (stream)
Return stream's file descriptor as an integer, if known. Otherwise return stream itself. The result of this function can be passed to make-ssl-client-stream and make-ssl-server-stream.

Function CL+SSL:RANDOM-BYTES (count)
Generates count cryptographically strong pseudo-random bytes. Returns the bytes as a simple-array with element-type '(unsigned-byte 8). Signals an error in case of problems, for example when the OpenSSL random number generator has not been seeded with enough randomness to ensure an unpredictable byte sequence.

Portability

CL+SSL requires CFFI with callback support.

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

Lisp Implementation Status Comments
OpenMCLWorking
SBCLWorking
CMU CLWorking
CLISPWorking
LispWorksWorking
Allegro Broken segfault
Corman CLUnknown
Digitool MCLUnknown
Scieneer CLUnknown
ECLUnknown
GCLUnknown

TODO

  • CNAME checking
  • session caching
  • The FFI code for all platforms except clisp needs to be rewritten.

News

2011-05-22

  • Added new public function RANDOM-BYTES.

2011-05-22

  • The source code repository is moved to Git.

2011-03-25

  • OpenSSL libraries names for OpenBSD, thanks to Thomas de Grivel.

2010-05-26

  • Fixed two bugs in LISTEN, thanks to Ron Garret.

2009-09-17

  • libssl loading on FreeBSD 7.2 fixed, thanks to Stian Sletner.

2008-xx-yy

  • Support for I/O deadlines (Clozure CL and SBCL).
  • Support for encrypted keys, thanks to Vsevolod Dyomkin.
  • Chained certificates support, thanks to Juhani Ränkimies.
  • More secure initialization of OpenSSL random number generator.
  • Minor CLISP-specific fixes.

2007-xx-yy

  • Fixed windows support, thanks to Matthew Kennedy and Anton Vodonosov.

2007-07-07

2007-01-16: CL+SSL is now available under an MIT-style license.

cl+ssl-20170630-git/src/000077500000000000000000000000001311543060700145215ustar00rootroot00000000000000cl+ssl-20170630-git/src/bio.lisp000066400000000000000000000100301311543060700161550ustar00rootroot00000000000000;;; Copyright (C) 2005 David Lichteblau ;;; ;;; See LICENSE for details. #+xcvb (module (:depends-on ("package"))) (in-package cl+ssl) (defconstant +bio-type-socket+ (logior 5 #x0400 #x0100)) (defconstant +BIO_FLAGS_READ+ 1) (defconstant +BIO_FLAGS_WRITE+ 2) (defconstant +BIO_FLAGS_SHOULD_RETRY+ 8) (defconstant +BIO_CTRL_FLUSH+ 11) (cffi:defcstruct bio-method (type :int) (name :pointer) (bwrite :pointer) (bread :pointer) (bputs :pointer) (bgets :pointer) (ctrl :pointer) (create :pointer) (destroy :pointer) (callback-ctrl :pointer)) (cffi:defcstruct bio (method :pointer) (callback :pointer) (cb-arg :pointer) (init :int) (shutdown :int) (flags :int) (retry-reason :int) (num :int) (ptr :pointer) (next-bio :pointer) (prev-bio :pointer) (references :int) (num-read :unsigned-long) (num-write :unsigned-long) (crypto-ex-data-stack :pointer) (crypto-ex-data-dummy :int)) (defun make-bio-lisp-method () (let ((m (cffi:foreign-alloc '(:struct bio-method)))) (setf (cffi:foreign-slot-value m '(:struct bio-method) 'type) ;; fixme: this is wrong, but presumably still better than some ;; random value here. +bio-type-socket+) (macrolet ((slot (name) `(cffi:foreign-slot-value m '(:struct bio-method) ,name))) (setf (slot 'name) (cffi:foreign-string-alloc "lisp")) (setf (slot 'bwrite) (cffi:callback lisp-write)) (setf (slot 'bread) (cffi:callback lisp-read)) (setf (slot 'bputs) (cffi:callback lisp-puts)) (setf (slot 'bgets) (cffi:null-pointer)) (setf (slot 'ctrl) (cffi:callback lisp-ctrl)) (setf (slot 'create) (cffi:callback lisp-create)) (setf (slot 'destroy) (cffi:callback lisp-destroy)) (setf (slot 'callback-ctrl) (cffi:null-pointer))) m)) (defun bio-new-lisp () (bio-new *bio-lisp-method*)) ;;; "cargo cult" (cffi:defcallback lisp-write :int ((bio :pointer) (buf :pointer) (n :int)) bio (dotimes (i n) (write-byte (cffi:mem-ref buf :unsigned-char i) *socket*)) (finish-output *socket*) n) (defun clear-retry-flags (bio) (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) (logandc2 (cffi:foreign-slot-value bio '(:struct bio) 'flags) (logior +BIO_FLAGS_READ+ +BIO_FLAGS_WRITE+ +BIO_FLAGS_SHOULD_RETRY+)))) (defun set-retry-read (bio) (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) (logior (cffi:foreign-slot-value bio '(:struct bio) 'flags) +BIO_FLAGS_READ+ +BIO_FLAGS_SHOULD_RETRY+))) (cffi:defcallback lisp-read :int ((bio :pointer) (buf :pointer) (n :int)) bio buf n (let ((i 0)) (handler-case (unless (or (cffi:null-pointer-p buf) (null n)) (clear-retry-flags bio) (when (or *blockp* (listen *socket*)) (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*)) (incf i)) (loop while (and (< i n) (or (null *partial-read-p*) (listen *socket*))) do (setf (cffi:mem-ref buf :unsigned-char i) (read-byte *socket*)) (incf i)) #+(or) (when (zerop i) (set-retry-read bio))) (end-of-file ())) i)) (cffi:defcallback lisp-puts :int ((bio :pointer) (buf :string)) bio buf (error "lisp-puts not implemented")) (cffi:defcallback lisp-ctrl :int ((bio :pointer) (cmd :int) (larg :long) (parg :pointer)) bio larg parg (cond ((eql cmd +BIO_CTRL_FLUSH+) 1) (t ;; (warn "lisp-ctrl(~A,~A,~A)" cmd larg parg) 0))) (cffi:defcallback lisp-create :int ((bio :pointer)) (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 1) (setf (cffi:foreign-slot-value bio '(:struct bio) 'num) 0) (setf (cffi:foreign-slot-value bio '(:struct bio) 'ptr) (cffi:null-pointer)) (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0) 1) (cffi:defcallback lisp-destroy :int ((bio :pointer)) (cond ((cffi:null-pointer-p bio) 0) (t (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 0) (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0) 1))) (setf *bio-lisp-method* nil) ;force reinit if anything changed here cl+ssl-20170630-git/src/conditions.lisp000066400000000000000000000326101311543060700175650ustar00rootroot00000000000000;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. #+xcvb (module (:depends-on ("package"))) (in-package :cl+ssl) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +ssl-error-none+ 0) (defconstant +ssl-error-ssl+ 1) (defconstant +ssl-error-want-read+ 2) (defconstant +ssl-error-want-write+ 3) (defconstant +ssl-error-want-x509-lookup+ 4) (defconstant +ssl-error-syscall+ 5) (defconstant +ssl-error-zero-return+ 6) (defconstant +ssl-error-want-connect+ 7)) ;;; Condition hierarchy ;;; (defun read-ssl-error-queue () (loop :for error-code = (err-get-error) :until (zerop error-code) :collect error-code)) (defun format-ssl-error-queue (stream-designator queue-designator) "STREAM-DESIGNATOR is the same as CL:FORMAT accepts: T, NIL, or a stream. QUEUE-DESIGNATOR is either a list of error codes (as returned by READ-SSL-ERROR-QUEUE) or an SSL-ERROR condition." (flet ((body (stream) (let ((queue (etypecase queue-designator (ssl-error (ssl-error-queue queue-designator)) (list queue-designator)))) (format stream "SSL error queue") (if queue (progn (format stream ":~%") (loop :for error-code :in queue :do (format stream "~a~%" (err-error-string error-code (cffi:null-pointer))))) (format stream " is empty."))))) (case stream-designator ((t) (body *standard-output*)) ((nil) (let ((s (make-string-output-stream :element-type 'character))) (unwind-protect (body s) (close s)) (get-output-stream-string s))) (otherwise (body stream-designator))))) (define-condition ssl-error (error) ( ;; Stores list of error codes ;; (as returned by the READ-SSL-ERROR-QUEUE function) (queue :initform nil :initarg :queue :reader ssl-error-queue))) (define-condition ssl-error/handle (ssl-error) ((ret :initarg :ret :reader ssl-error-ret) (handle :initarg :handle :reader ssl-error-handle)) (:report (lambda (condition stream) (format stream "Unspecified error ~A on handle ~A~%" (ssl-error-ret condition) (ssl-error-handle condition)) (format-ssl-error-queue stream condition)))) (define-condition ssl-error-initialize (ssl-error) ((reason :initarg :reason :reader ssl-error-reason)) (:report (lambda (condition stream) (format stream "SSL initialization error: ~A~%" (ssl-error-reason condition)) (format-ssl-error-queue stream condition)))) (define-condition ssl-error-want-something (ssl-error/handle) ()) ;;;SSL_ERROR_NONE (define-condition ssl-error-none (ssl-error/handle) () (:documentation "The TLS/SSL I/O operation completed. This result code is returned if and only if ret > 0.") (:report (lambda (condition stream) (format stream "The TLS/SSL operation on handle ~A completed (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition)) (format-ssl-error-queue stream condition)))) ;; SSL_ERROR_ZERO_RETURN (define-condition ssl-error-zero-return (ssl-error/handle) () (:documentation "The TLS/SSL connection has been closed. If the protocol version is SSL 3.0 or TLS 1.0, this result code is returned only if a closure alert has occurred in the protocol, i.e. if the connection has been closed cleanly. Note that in this case SSL_ERROR_ZERO_RETURN does not necessarily indicate that the underlying transport has been closed.") (:report (lambda (condition stream) (format stream "The TLS/SSL connection on handle ~A has been closed (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition)) (format-ssl-error-queue stream condition)))) ;; SSL_ERROR_WANT_READ (define-condition ssl-error-want-read (ssl-error-want-something) () (:documentation "The operation did not complete; the same TLS/SSL I/O function should be called again later. If, by then, the underlying BIO has data available for reading (if the result code is SSL_ERROR_WANT_READ) or allows writing data (SSL_ERROR_WANT_WRITE), then some TLS/SSL protocol progress will take place, i.e. at least part of an TLS/SSL record will be read or written. Note that the retry may again lead to a SSL_ERROR_WANT_READ or SSL_ERROR_WANT_WRITE condition. There is no fixed upper limit for the number of iterations that may be necessary until progress becomes visible at application protocol level.") (:report (lambda (condition stream) (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a READ (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition)) (format-ssl-error-queue stream condition)))) ;; SSL_ERROR_WANT_WRITE (define-condition ssl-error-want-write (ssl-error-want-something) () (:documentation "The operation did not complete; the same TLS/SSL I/O function should be called again later. If, by then, the underlying BIO has data available for reading (if the result code is SSL_ERROR_WANT_READ) or allows writing data (SSL_ERROR_WANT_WRITE), then some TLS/SSL protocol progress will take place, i.e. at least part of an TLS/SSL record will be read or written. Note that the retry may again lead to a SSL_ERROR_WANT_READ or SSL_ERROR_WANT_WRITE condition. There is no fixed upper limit for the number of iterations that may be necessary until progress becomes visible at application protocol level.") (:report (lambda (condition stream) (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a WRITE (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition)) (format-ssl-error-queue stream condition)))) ;; SSL_ERROR_WANT_CONNECT (define-condition ssl-error-want-connect (ssl-error-want-something) () (:documentation "The operation did not complete; the same TLS/SSL I/O function should be called again later. The underlying BIO was not connected yet to the peer and the call would block in connect()/accept(). The SSL function should be called again when the connection is established. These messages can only appear with a BIO_s_connect() or BIO_s_accept() BIO, respectively. In order to find out, when the connection has been successfully established, on many platforms select() or poll() for writing on the socket file descriptor can be used.") (:report (lambda (condition stream) (format stream "The TLS/SSL operation on handle ~A did not complete: It wants a connect first (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition)) (format-ssl-error-queue stream condition)))) ;; SSL_ERROR_WANT_X509_LOOKUP (define-condition ssl-error-want-x509-lookup (ssl-error-want-something) () (:documentation "The operation did not complete because an application callback set by SSL_CTX_set_client_cert_cb() has asked to be called again. The TLS/SSL I/O function should be called again later. Details depend on the application.") (:report (lambda (condition stream) (format stream "The TLS/SSL operation on handle ~A did not complete: An application callback wants to be called again (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition)) (format-ssl-error-queue stream condition)))) ;; SSL_ERROR_SYSCALL (define-condition ssl-error-syscall (ssl-error/handle) ((syscall :initarg :syscall)) (:documentation "Some I/O error occurred. The OpenSSL error queue may contain more information on the error. If the error queue is empty (i.e. ERR_get_error() returns 0), ret can be used to find out more about the error: If ret == 0, an EOF was observed that violates the protocol. If ret == -1, the underlying BIO reported an I/O error (for socket I/O on Unix systems, consult errno for details).") (:report (lambda (condition stream) (if (zerop (length (ssl-error-queue condition))) (case (ssl-error-ret condition) (0 (format stream "An I/O error occurred: An unexpected EOF was observed on handle ~A (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition))) (-1 (format stream "An I/O error occurred in the underlying BIO (return code: ~A).~%" (ssl-error-ret condition))) (otherwise (format stream "An I/O error occurred: undocumented reason (return code: ~A).~%" (ssl-error-ret condition)))) (format stream "An UNKNOWN I/O error occurred in the underlying BIO (return code: ~A).~%" (ssl-error-ret condition))) (format-ssl-error-queue stream condition)))) ;; SSL_ERROR_SSL (define-condition ssl-error-ssl (ssl-error/handle) () (:documentation "A failure in the SSL library occurred, usually a protocol error. The OpenSSL error queue contains more information on the error.") (:report (lambda (condition stream) (format stream "A failure in the SSL library occurred on handle ~A (return code: ~A).~%" (ssl-error-handle condition) (ssl-error-ret condition)) (format-ssl-error-queue stream condition)))) (defun ssl-signal-error (handle syscall error-code original-error) (let ((queue (read-ssl-error-queue))) (if (and (eql error-code #.+ssl-error-syscall+) (not (zerop original-error))) (error 'ssl-error-syscall :handle handle :ret error-code :queue queue :syscall syscall) (error (case error-code (#.+ssl-error-none+ 'ssl-error-none) (#.+ssl-error-ssl+ 'ssl-error-ssl) (#.+ssl-error-want-read+ 'ssl-error-want-read) (#.+ssl-error-want-write+ 'ssl-error-want-write) (#.+ssl-error-want-x509-lookup+ 'ssl-error-want-x509-lookup) (#.+ssl-error-zero-return+ 'ssl-error-zero-return) (#.+ssl-error-want-connect+ 'ssl-error-want-connect) (#.+ssl-error-syscall+ 'ssl-error-zero-return) ; this is intentional here. we got an EOF from the syscall (ret is 0) (t 'ssl-error/handle)) :handle handle :ret error-code :queue queue)))) (defparameter *ssl-verify-error-alist* '((0 :X509_V_OK) (2 :X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT) (3 :X509_V_ERR_UNABLE_TO_GET_CRL) (4 :X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE) (5 :X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE) (6 :X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY) (7 :X509_V_ERR_CERT_SIGNATURE_FAILURE) (8 :X509_V_ERR_CRL_SIGNATURE_FAILURE) (9 :X509_V_ERR_CERT_NOT_YET_VALID) (10 :X509_V_ERR_CERT_HAS_EXPIRED) (11 :X509_V_ERR_CRL_NOT_YET_VALID) (12 :X509_V_ERR_CRL_HAS_EXPIRED) (13 :X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD) (14 :X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD) (15 :X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD) (16 :X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD) (17 :X509_V_ERR_OUT_OF_MEM) (18 :X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT) (19 :X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN) (20 :X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY) (21 :X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE) (22 :X509_V_ERR_CERT_CHAIN_TOO_LONG) (23 :X509_V_ERR_CERT_REVOKED) (24 :X509_V_ERR_INVALID_CA) (25 :X509_V_ERR_PATH_LENGTH_EXCEEDED) (26 :X509_V_ERR_INVALID_PURPOSE) (27 :X509_V_ERR_CERT_UNTRUSTED) (28 :X509_V_ERR_CERT_REJECTED) (29 :X509_V_ERR_SUBJECT_ISSUER_MISMATCH) (30 :X509_V_ERR_AKID_SKID_MISMATCH) (31 :X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH) (32 :X509_V_ERR_KEYUSAGE_NO_CERTSIGN) (50 :X509_V_ERR_APPLICATION_VERIFICATION))) (defun ssl-verify-error-keyword (code) (cadr (assoc code *ssl-verify-error-alist*))) (defun ssl-verify-error-code (keyword) (caar (member keyword *ssl-verify-error-alist* :key #'cadr))) (define-condition ssl-error-verify (ssl-error) ((stream :initarg :stream :reader ssl-error-stream :documentation "The SSL stream whose peer certificate didn't verify.") (error-code :initarg :error-code :reader ssl-error-code :documentation "The peer certificate verification error code.")) (:report (lambda (condition stream) (let ((code (ssl-error-code condition))) (format stream "SSL verify error: ~d~@[ ~a~]" code (ssl-verify-error-keyword code))))) (:documentation "This condition is signalled on SSL connection when a peer certificate doesn't verify.")) (define-condition ssl-error-call (cl+ssl::ssl-error) ((message :initarg :message)) (:documentation "A failure in the SSL library occurred..") (:report (lambda (condition stream) (format stream "A failure in OpenSSL library occurred~@[: ~A~].~%" (slot-value condition 'message)) (cl+ssl::format-ssl-error-queue stream (cl+ssl::ssl-error-queue condition))))) cl+ssl-20170630-git/src/context.lisp000066400000000000000000000131361311543060700171020ustar00rootroot00000000000000(in-package :cl+ssl) (define-condition verify-location-not-found-error (ssl-error) ((location :initarg :location)) (:documentation "Unable to find verify locations") (:report (lambda (condition stream) (format stream "Unable to find verify location. Path: ~A" (slot-value condition 'location))))) (defun validate-verify-location (location) (handler-case (cond ((uiop:file-exists-p location) (values location t)) ((uiop:directory-exists-p location) (values location nil)) (t (error 'verify-location-not-found-error :location location))))) (defun add-verify-locations (ctx locations) (dolist (location locations) (multiple-value-bind (location isfile) (validate-verify-location location) (cffi:with-foreign-strings ((location-ptr location)) (unless (= 1 (cl+ssl::ssl-ctx-load-verify-locations ctx (if isfile location-ptr (cffi:null-pointer)) (if isfile (cffi:null-pointer) location-ptr))) (error 'ssl-error :queue (read-ssl-error-queue) :message (format nil "Unable to load verify location ~A" location))))))) (defun ssl-ctx-set-verify-location (ctx location) (cond ((eq :default location) (unless (= 1 (ssl-ctx-set-default-verify-paths ctx)) (error 'ssl-error-call :queue (read-ssl-error-queue) :message (format nil "Unable to load default verify paths")))) ((eq :default-file location) (unless (= 1 (ssl-ctx-set-default-verify-file ctx)) (error 'ssl-error-call :queue (read-ssl-error-queue) :message (format nil "Unable to load default verify file")))) ((eq :default-dir location) (unless (= 1 (ssl-ctx-set-default-verify-dir ctx)) (error 'ssl-error-call :queue (read-ssl-error-queue) :message (format nil "Unable to load default verify dir")))) ((stringp location) (add-verify-locations ctx (list location))) ((pathnamep location) (add-verify-locations ctx (list location))) ((and location (listp location)) (add-verify-locations ctx location)) ;; silently allow NIL as location (location (error "Invalid location ~a" location)))) (alexandria:define-constant +default-cipher-list+ (format nil "ECDHE-RSA-AES256-GCM-SHA384:~ ECDHE-RSA-AES256-SHA384:~ ECDHE-RSA-AES256-SHA:~ ECDHE-RSA-AES128-GCM-SHA256:~ ECDHE-RSA-AES128-SHA256:~ ECDHE-RSA-AES128-SHA:~ ECDHE-RSA-RC4-SHA:~ DHE-RSA-AES256-GCM-SHA384:~ DHE-RSA-AES256-SHA256:~ DHE-RSA-AES256-SHA:~ DHE-RSA-AES128-GCM-SHA256:~ DHE-RSA-AES128-SHA256:~ DHE-RSA-AES128-SHA:~ AES256-GCM-SHA384:~ AES256-SHA256:~ AES256-SHA:~ AES128-GCM-SHA256:~ AES128-SHA256:~ AES128-SHA") :test 'equal) (cffi:defcallback verify-peer-callback :int ((ok :int) (ctx :pointer)) (let ((error-code (x509-store-ctx-get-error ctx))) (unless (= error-code 0) (error 'ssl-error-verify :error-code error-code)) ok)) (defun make-context (&key (method nil method-supplied-p) (disabled-protocols) (options (list +SSL-OP-ALL+)) (session-cache-mode +ssl-sess-cache-server+) (verify-location :default) (verify-depth 100) (verify-mode +ssl-verify-peer+) (verify-callback nil verify-callback-supplied-p) (cipher-list +default-cipher-list+) (pem-password-callback 'pem-password-callback)) (ensure-initialized) (let ((ctx (ssl-ctx-new (if method-supplied-p method (progn (unless disabled-protocols (setf disabled-protocols (list +SSL-OP-NO-SSLv2+ +SSL-OP-NO-SSLv3+))) (ssl-v23-method)))))) (when (cffi:null-pointer-p ctx) (error 'ssl-error-initialize :reason "Can't create new SSL CTX" :queue (read-ssl-error-queue))) (handler-bind ((error (lambda (_) (declare (ignore _)) (ssl-ctx-free ctx)))) (ssl-ctx-set-options ctx (apply #'logior (append disabled-protocols options))) (ssl-ctx-set-session-cache-mode ctx session-cache-mode) (ssl-ctx-set-verify-location ctx verify-location) (ssl-ctx-set-verify-depth ctx verify-depth) (ssl-ctx-set-verify ctx verify-mode (if verify-callback (cffi:get-callback verify-callback) (if verify-callback-supplied-p (cffi:null-pointer) (if (= verify-mode +ssl-verify-peer+) (cffi:callback verify-peer-callback) (cffi:null-pointer))))) (ssl-ctx-set-cipher-list ctx cipher-list) (ssl-ctx-set-default-passwd-cb ctx (cffi:get-callback pem-password-callback)) ctx))) (defun call-with-global-context (context auto-free-p body-fn) (let* ((*ssl-global-context* context)) (unwind-protect (funcall body-fn) (when auto-free-p (ssl-ctx-free context))))) (defmacro with-global-context ((context &key auto-free-p) &body body) `(call-with-global-context ,context ,auto-free-p (lambda () ,@body))) cl+ssl-20170630-git/src/ffi-1.1.0.lisp000066400000000000000000000006131311543060700166110ustar00rootroot00000000000000(defpackage :openssl-1.1.0 (:nicknames :ossl-1.1.0 :ossl110) (:use :common-lisp) (:export #:ssl-ctx-set-default-verify-dir #:ssl-ctx-set-default-verify-file)) (cffi:defcfun ("SSL_CTX_set_default_verify_dir" ssl-ctx-set-default-verify-dir) :int (ctx :pointer)) (cffi:defcfun ("SSL_CTX_set_default_verify_file" ssl-ctx-set-default-verify-file) :int (ctx :pointer)) cl+ssl-20170630-git/src/ffi-buffer-all.lisp000066400000000000000000000003451311543060700201750ustar00rootroot00000000000000#+xcvb (module (:depends-on ("package"))) (in-package :cl+ssl) (defconstant +initial-buffer-size+ 2048) (declaim (inline make-buffer buffer-length buffer-elt set-buffer-elt s/b-replace b/s-replace)) cl+ssl-20170630-git/src/ffi-buffer-clisp.lisp000066400000000000000000000027051311543060700205410ustar00rootroot00000000000000#+xcvb (module (:depends-on ("package" "reload" "conditions" "ffi" "ffi-buffer-all"))) (in-package :cl+ssl) (defun make-buffer (size) (cffi-sys:%foreign-alloc size)) (defun buffer-length (buf) (declare (ignore buf)) +initial-buffer-size+) (defun buffer-elt (buf index) (ffi:memory-as buf 'ffi:uint8 index)) (defun set-buffer-elt (buf index val) (setf (ffi:memory-as buf 'ffi:uint8 index) val)) (defsetf buffer-elt set-buffer-elt) (declaim (inline calc-buf-end)) ;; to calculate non NIL value of the buffer end index (defun calc-buf-end (buf-start seq seq-start seq-end) (+ buf-start (- (or seq-end (length seq)) seq-start))) (defun s/b-replace (seq buf &key (start1 0) end1 (start2 0) end2) (when (null end2) (setf end2 (calc-buf-end start2 seq start1 end1))) (replace seq (ffi:memory-as buf (ffi:parse-c-type `(ffi:c-array ffi:uint8 ,(- end2 start2))) start2) :start1 start1 :end1 end1)) (defun as-vector (seq) (if (typep seq 'vector) seq (make-array (length seq) :initial-contents seq :element-type '(unsigned-byte 8)))) (defun b/s-replace (buf seq &key (start1 0) end1 (start2 0) end2) (when (null end1) (setf end1 (calc-buf-end start1 seq start2 end2))) (setf (ffi:memory-as buf (ffi:parse-c-type `(ffi:c-array ffi:uint8 ,(- end1 start1))) start1) (as-vector (subseq seq start2 end2))) seq) (defmacro with-pointer-to-vector-data ((ptr buf) &body body) `(let ((,ptr ,buf)) ,@body)) cl+ssl-20170630-git/src/ffi-buffer.lisp000066400000000000000000000014001311543060700174200ustar00rootroot00000000000000#+xcvb (module (:depends-on ("package"))) (in-package :cl+ssl) (defun make-buffer (size) (cffi-sys::make-shareable-byte-vector size)) (defun buffer-length (buf) (length buf)) (defun buffer-elt (buf index) (elt buf index)) (defun set-buffer-elt (buf index val) (setf (elt buf index) val)) (defsetf buffer-elt set-buffer-elt) (defun s/b-replace (seq buf &key (start1 0) end1 (start2 0) end2) (replace seq buf :start1 start1 :end1 end1 :start2 start2 :end2 end2)) (defun b/s-replace (buf seq &key (start1 0) end1 (start2 0) end2) (replace buf seq :start1 start1 :end1 end1 :start2 start2 :end2 end2)) (defmacro with-pointer-to-vector-data ((ptr buf) &body body) `(cffi-sys::with-pointer-to-vector-data (,ptr ,buf) ,@body)) cl+ssl-20170630-git/src/ffi.lisp000066400000000000000000000557331311543060700161730ustar00rootroot00000000000000;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. #+xcvb (module (:depends-on ("package" "conditions"))) (eval-when (:compile-toplevel) (declaim (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0)))) (in-package :cl+ssl) ;;; Global state ;;; (defvar *ssl-global-context* nil) (defvar *ssl-global-method* nil) (defvar *bio-lisp-method* nil) (defparameter *blockp* t) (defparameter *partial-read-p* nil) (defun ssl-initialized-p () (and *ssl-global-context* *ssl-global-method*)) ;;; Constants ;;; (defconstant +ssl-filetype-pem+ 1) (defconstant +ssl-filetype-asn1+ 2) (defconstant +ssl-filetype-default+ 3) (defconstant +SSL-CTRL-OPTIONS+ 32) (defconstant +SSL_CTRL_SET_SESS_CACHE_MODE+ 44) (defconstant +SSL_CTRL_MODE+ 33) (defconstant +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 2) (defconstant +RSA_F4+ #x10001) (defconstant +SSL-SESS-CACHE-OFF+ #x0000 "No session caching for client or server takes place.") (defconstant +SSL-SESS-CACHE-CLIENT+ #x0001 "Client sessions are added to the session cache. As there is no reliable way for the OpenSSL library to know whether a session should be reused or which session to choose (due to the abstract BIO layer the SSL engine does not have details about the connection), the application must select the session to be reused by using the SSL-SET-SESSION function. This option is not activated by default.") (defconstant +SSL-SESS-CACHE-SERVER+ #x0002 "Server sessions are added to the session cache. When a client proposes a session to be reused, the server looks for the corresponding session in (first) the internal session cache (unless +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ is set), then (second) in the external cache if available. If the session is found, the server will try to reuse the session. This is the default.") (defconstant +SSL-SESS-CACHE-BOTH+ (logior +SSL-SESS-CACHE-CLIENT+ +SSL-SESS-CACHE-SERVER+) "Enable both +SSL-SESS-CACHE-CLIENT+ and +SSL-SESS-CACHE-SERVER+ at the same time.") (defconstant +SSL-SESS-CACHE-NO-AUTO-CLEAR+ #x0080 "Normally the session cache is checked for expired sessions every 255 connections using the SSL-CTX-FLUSH-SESSIONS function. Since this may lead to a delay which cannot be controlled, the automatic flushing may be disabled and SSL-CTX-FLUSH-SESSIONS can be called explicitly by the application.") (defconstant +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ #x0100 "By setting this flag, session-resume operations in an SSL/TLS server will not automatically look up sessions in the internal cache, even if sessions are automatically stored there. If external session caching callbacks are in use, this flag guarantees that all lookups are directed to the external cache. As automatic lookup only applies for SSL/TLS servers, the flag has no effect on clients.") (defconstant +SSL-SESS-CACHE-NO-INTERNAL-STORE+ #x0200 "Depending on the presence of +SSL-SESS-CACHE-CLIENT+ and/or +SSL-SESS-CACHE-SERVER+, sessions negotiated in an SSL/TLS handshake may be cached for possible reuse. Normally a new session is added to the internal cache as well as any external session caching (callback) that is configured for the SSL-CTX. This flag will prevent sessions being stored in the internal cache (though the application can add them manually using SSL-CTX-ADD-SESSION). Note: in any SSL/TLS servers where external caching is configured, any successful session lookups in the external cache (ie. for session-resume requests) would normally be copied into the local cache before processing continues - this flag prevents these additions to the internal cache as well.") (defconstant +SSL-SESS-CACHE-NO-INTERNAL+ (logior +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ +SSL-SESS-CACHE-NO-INTERNAL-STORE+) "Enable both +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ and +SSL-SESS-CACHE-NO-INTERNAL-STORE+ at the same time.") (defconstant +SSL-VERIFY-NONE+ #x00) (defconstant +SSL-VERIFY-PEER+ #x01) (defconstant +SSL-VERIFY-FAIL-IF-NO-PEER-CERT+ #x02) (defconstant +SSL-VERIFY-CLIENT-ONCE+ #x04) (defconstant +SSL-OP-ALL+ #x80000BFF) (defconstant +SSL-OP-NO-SSLv2+ #x00000000) (defconstant +SSL-OP-NO-SSLv3+ #x02000000) (defconstant +SSL-OP-NO-TLSv1+ #x04000000) (defconstant +SSL-OP-NO-TLSv1-2+ #x08000000) (defconstant +SSL-OP-NO-TLSv1-1+ #x10000000) (defvar *tmp-rsa-key-512* nil) (defvar *tmp-rsa-key-1024* nil) (defvar *tmp-rsa-key-2048* nil) ;;; Misc ;;; (defmacro while (cond &body body) `(do () ((not ,cond)) ,@body)) ;;; Function definitions ;;; (cffi:defcfun (#-windows "close" #+windows "closesocket" close-socket) :int (socket :int)) (declaim (inline ssl-write ssl-read ssl-connect ssl-accept)) (cffi:defctype ssl-method :pointer) (cffi:defctype ssl-ctx :pointer) (cffi:defctype ssl-pointer :pointer) (cffi:defcfun ("SSL_get_version" ssl-get-version) :string (ssl ssl-pointer)) (cffi:defcfun ("SSL_load_error_strings" ssl-load-error-strings) :void) (cffi:defcfun ("SSL_library_init" ssl-library-init) :int) ;; ;; We don't refer SSLv2_client_method as the default ;; builds of OpenSSL do not have it, due to insecurity ;; of the SSL v2 protocol (see https://www.openssl.org/docs/ssl/SSL_CTX_new.html ;; and https://github.com/cl-plus-ssl/cl-plus-ssl/issues/6) ;; ;; (cffi:defcfun ("SSLv2_client_method" ssl-v2-client-method) ;; ssl-method) (cffi:defcfun ("SSLv23_client_method" ssl-v23-client-method) ssl-method) (cffi:defcfun ("SSLv23_server_method" ssl-v23-server-method) ssl-method) (cffi:defcfun ("SSLv23_method" ssl-v23-method) ssl-method) (cffi:defcfun ("SSLv3_client_method" ssl-v3-client-method) ssl-method) (cffi:defcfun ("SSLv3_server_method" ssl-v3-server-method) ssl-method) (cffi:defcfun ("SSLv3_method" ssl-v3-method) ssl-method) (cffi:defcfun ("TLSv1_client_method" ssl-TLSv1-client-method) ssl-method) (cffi:defcfun ("TLSv1_server_method" ssl-TLSv1-server-method) ssl-method) (cffi:defcfun ("TLSv1_method" ssl-TLSv1-method) ssl-method) (cffi:defcfun ("TLSv1_1_client_method" ssl-TLSv1-1-client-method) ssl-method) (cffi:defcfun ("TLSv1_1_server_method" ssl-TLSv1-1-server-method) ssl-method) (cffi:defcfun ("TLSv1_1_method" ssl-TLSv1-1-method) ssl-method) (cffi:defcfun ("TLSv1_2_client_method" ssl-TLSv1-2-client-method) ssl-method) (cffi:defcfun ("TLSv1_2_server_method" ssl-TLSv1-2-server-method) ssl-method) (cffi:defcfun ("TLSv1_2_method" ssl-TLSv1-2-method) ssl-method) (cffi:defcfun ("SSL_CTX_new" ssl-ctx-new) ssl-ctx (method ssl-method)) (cffi:defcfun ("SSL_new" ssl-new) ssl-pointer (ctx ssl-ctx)) (cffi:defcfun ("SSL_get_fd" ssl-get-fd) :int (ssl ssl-pointer)) (cffi:defcfun ("SSL_set_fd" ssl-set-fd) :int (ssl ssl-pointer) (fd :int)) (cffi:defcfun ("SSL_set_bio" ssl-set-bio) :void (ssl ssl-pointer) (rbio :pointer) (wbio :pointer)) (cffi:defcfun ("SSL_get_error" ssl-get-error) :int (ssl ssl-pointer) (ret :int)) (cffi:defcfun ("SSL_set_connect_state" ssl-set-connect-state) :void (ssl ssl-pointer)) (cffi:defcfun ("SSL_set_accept_state" ssl-set-accept-state) :void (ssl ssl-pointer)) (cffi:defcfun ("SSL_connect" ssl-connect) :int (ssl ssl-pointer)) (cffi:defcfun ("SSL_accept" ssl-accept) :int (ssl ssl-pointer)) (cffi:defcfun ("SSL_write" ssl-write) :int (ssl ssl-pointer) (buf :pointer) (num :int)) (cffi:defcfun ("SSL_read" ssl-read) :int (ssl ssl-pointer) (buf :pointer) (num :int)) (cffi:defcfun ("SSL_shutdown" ssl-shutdown) :void (ssl ssl-pointer)) (cffi:defcfun ("SSL_free" ssl-free) :void (ssl ssl-pointer)) (cffi:defcfun ("SSL_CTX_free" ssl-ctx-free) :void (ctx ssl-ctx)) (cffi:defcfun ("BIO_ctrl" bio-set-fd) :long (bio :pointer) (cmd :int) (larg :long) (parg :pointer)) (cffi:defcfun ("BIO_new_socket" bio-new-socket) :pointer (fd :int) (close-flag :int)) (cffi:defcfun ("BIO_new" bio-new) :pointer (method :pointer)) (cffi:defcfun ("ERR_get_error" err-get-error) :unsigned-long) (cffi:defcfun ("ERR_error_string" err-error-string) :string (e :unsigned-long) (buf :pointer)) (cffi:defcfun ("SSL_set_cipher_list" ssl-set-cipher-list) :int (ssl ssl-pointer) (str :string)) (cffi:defcfun ("SSL_use_RSAPrivateKey_file" ssl-use-rsa-privatekey-file) :int (ssl ssl-pointer) (str :string) ;; either +ssl-filetype-pem+ or +ssl-filetype-asn1+ (type :int)) (cffi:defcfun ("SSL_CTX_use_RSAPrivateKey_file" ssl-ctx-use-rsa-privatekey-file) :int (ctx ssl-ctx) (type :int)) (cffi:defcfun ("SSL_use_certificate_file" ssl-use-certificate-file) :int (ssl ssl-pointer) (str :string) (type :int)) #+new-openssl (cffi:defcfun ("SSL_CTX_set_options" ssl-ctx-set-options) :long (ctx :pointer) (options :long)) #-new-openssl (defun ssl-ctx-set-options (ctx options) (ssl-ctx-ctrl ctx +SSL-CTRL-OPTIONS+ options (cffi:null-pointer))) (cffi:defcfun ("SSL_CTX_set_cipher_list" ssl-ctx-set-cipher-list%) :int (ctx :pointer) (ciphers :pointer)) (defun ssl-ctx-set-cipher-list (ctx ciphers) (cffi:with-foreign-string (ciphers* ciphers) (when (= 0 (ssl-ctx-set-cipher-list% ctx ciphers*)) (error 'ssl-error-initialize :reason "Can't set SSL cipher list" :queue (read-ssl-error-queue))))) (cffi:defcfun ("SSL_CTX_use_certificate_chain_file" ssl-ctx-use-certificate-chain-file) :int (ctx ssl-ctx) (str :string)) (cffi:defcfun ("SSL_CTX_load_verify_locations" ssl-ctx-load-verify-locations) :int (ctx ssl-ctx) (CAfile :string) (CApath :string)) (cffi:defcfun ("SSL_CTX_set_client_CA_list" ssl-ctx-set-client-ca-list) :void (ctx ssl-ctx) (list ssl-pointer)) (cffi:defcfun ("SSL_load_client_CA_file" ssl-load-client-ca-file) ssl-pointer (file :string)) (cffi:defcfun ("SSL_CTX_ctrl" ssl-ctx-ctrl) :long (ctx ssl-ctx) (cmd :int) ;; Despite declared as long in the original OpenSSL headers, ;; passing to larg for example 2181041151 which is the result of ;; (logior cl+ssl::+SSL-OP-ALL+ ;; cl+ssl::+SSL-OP-NO-SSLv2+ ;; cl+ssl::+SSL-OP-NO-SSLv3+) ;; causes CFFI on 32 bit platforms to signal an error ;; "The value 2181041151 is not of the expected type (SIGNED-BYTE 32)" ;; The problem is that 2181041151 requires 32 bits by itself and ;; there is no place left for the sign bit. ;; In C the compiler silently coerces unsigned to signed, ;; but CFFI raises this error. ;; Therefore we use :UNSIGNED-LONG for LARG. (larg :unsigned-long) (parg :pointer)) (cffi:defcfun ("SSL_ctrl" ssl-ctrl) :long (ssl :pointer) (cmd :int) (larg :long) (parg :pointer)) (cffi:defcfun ("SSL_CTX_set_default_passwd_cb" ssl-ctx-set-default-passwd-cb) :void (ctx ssl-ctx) (pem_passwd_cb :pointer)) (cffi:defcfun ("CRYPTO_num_locks" crypto-num-locks) :int) (cffi:defcfun ("CRYPTO_set_locking_callback" crypto-set-locking-callback) :void (fun :pointer)) (cffi:defcfun ("CRYPTO_set_id_callback" crypto-set-id-callback) :void (fun :pointer)) (cffi:defcfun ("RAND_seed" rand-seed) :void (buf :pointer) (num :int)) (cffi:defcfun ("RAND_bytes" rand-bytes) :int (buf :pointer) (num :int)) (cffi:defcfun ("SSL_CTX_set_verify_depth" ssl-ctx-set-verify-depth) :void (ctx :pointer) (depth :int)) (cffi:defcfun ("SSL_CTX_set_verify" ssl-ctx-set-verify) :void (ctx :pointer) (mode :int) (verify-callback :pointer)) (cffi:defcfun ("SSL_get_verify_result" ssl-get-verify-result) :long (ssl ssl-pointer)) (cffi:defcfun ("SSL_get_peer_certificate" ssl-get-peer-certificate) :pointer (ssl ssl-pointer)) (cffi:defcfun ("X509_free" x509-free) :void (x509 :pointer)) (cffi:defcfun ("X509_NAME_oneline" x509-name-oneline) :pointer (x509-name :pointer) (buf :pointer) (size :int)) (cffi:defcfun ("X509_get_issuer_name" x509-get-issuer-name) :pointer ; *X509_NAME (x509 :pointer)) (cffi:defcfun ("X509_get_subject_name" x509-get-subject-name) :pointer ; *X509_NAME (x509 :pointer)) (cffi:defcfun ("X509_STORE_CTX_get_error" x509-store-ctx-get-error) :int (ctx :pointer)) (cffi:defcfun ("SSL_CTX_set_default_verify_paths" ssl-ctx-set-default-verify-paths) :int (ctx :pointer)) (cffi:defcfun ("RSA_generate_key" rsa-generate-key) :pointer (num :int) (e :unsigned-long) (callback :pointer) (opt :pointer)) (cffi:defcfun ("RSA_free" rsa-free) :void (rsa :pointer)) (cffi:defcfun ("SSL_CTX_set_tmp_rsa_callback" ssl-ctx-set-tmp-rsa-callback) :pointer (ctx :pointer) (callback :pointer)) (cffi:defcallback tmp-rsa-callback :pointer ((ssl :pointer) (export-p :int) (key-length :int)) (declare (ignore ssl export-p)) (flet ((rsa-key (length) (rsa-generate-key length +RSA_F4+ (cffi:null-pointer) (cffi:null-pointer)))) (cond ((= key-length 512) (unless *tmp-rsa-key-512* (setf *tmp-rsa-key-512* (rsa-key key-length))) *tmp-rsa-key-512*) ((= key-length 1024) (unless *tmp-rsa-key-1024* (setf *tmp-rsa-key-1024* (rsa-key key-length))) *tmp-rsa-key-1024*) (t (unless *tmp-rsa-key-2048* (setf *tmp-rsa-key-2048* (rsa-key key-length))) *tmp-rsa-key-2048*)))) ;;; Funcall wrapper ;;; (defvar *socket*) (declaim (inline ensure-ssl-funcall)) (defun ensure-ssl-funcall (stream handle func &rest args) (loop (let ((nbytes (let ((*socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks (apply func args)))) (when (plusp nbytes) (return nbytes)) (let ((error (ssl-get-error handle nbytes))) (case error (#.+ssl-error-want-read+ (input-wait stream (ssl-get-fd handle) (ssl-stream-deadline stream))) (#.+ssl-error-want-write+ (output-wait stream (ssl-get-fd handle) (ssl-stream-deadline stream))) (t (ssl-signal-error handle func error nbytes))))))) (declaim (inline nonblocking-ssl-funcall)) (defun nonblocking-ssl-funcall (stream handle func &rest args) (loop (let ((nbytes (let ((*socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks (apply func args)))) (when (plusp nbytes) (return nbytes)) (let ((error (ssl-get-error handle nbytes))) (case error ((#.+ssl-error-want-read+ #.+ssl-error-want-write+) (return nbytes)) (t (ssl-signal-error handle func error nbytes))))))) ;;; Waiting for output to be possible #+clozure-common-lisp (defun milliseconds-until-deadline (deadline stream) (let* ((now (get-internal-real-time))) (if (> now deadline) (error 'ccl::communication-deadline-expired :stream stream) (values (round (- deadline now) (/ internal-time-units-per-second 1000)))))) #+clozure-common-lisp (defun output-wait (stream fd deadline) (unless deadline (setf deadline (stream-deadline (ssl-stream-socket stream)))) (let* ((timeout (if deadline (milliseconds-until-deadline deadline stream) nil))) (multiple-value-bind (win timedout error) (ccl::process-output-wait fd timeout) (unless win (if timedout (error 'ccl::communication-deadline-expired :stream stream) (ccl::stream-io-error stream (- error) "write")))))) #+sbcl (defun output-wait (stream fd deadline) (declare (ignore stream)) (let ((timeout ;; *deadline* is handled by wait-until-fd-usable automatically, ;; but we need to turn a user-specified deadline into a timeout (when deadline (/ (- deadline (get-internal-real-time)) internal-time-units-per-second)))) (sb-sys:wait-until-fd-usable fd :output timeout))) #-(or clozure-common-lisp sbcl) (defun output-wait (stream fd deadline) (declare (ignore stream fd deadline)) ;; This situation means that the lisp set our fd to non-blocking mode, ;; and streams.lisp didn't know how to undo that. (warn "non-blocking stream encountered unexpectedly")) ;;; Waiting for input to be possible #+clozure-common-lisp (defun input-wait (stream fd deadline) (unless deadline (setf deadline (stream-deadline (ssl-stream-socket stream)))) (let* ((timeout (if deadline (milliseconds-until-deadline deadline stream) nil))) (multiple-value-bind (win timedout error) (ccl::process-input-wait fd timeout) (unless win (if timedout (error 'ccl::communication-deadline-expired :stream stream) (ccl::stream-io-error stream (- error) "read")))))) #+sbcl (defun input-wait (stream fd deadline) (declare (ignore stream)) (let ((timeout ;; *deadline* is handled by wait-until-fd-usable automatically, ;; but we need to turn a user-specified deadline into a timeout (when deadline (/ (- deadline (get-internal-real-time)) internal-time-units-per-second)))) (sb-sys:wait-until-fd-usable fd :input timeout))) #-(or clozure-common-lisp sbcl) (defun input-wait (stream fd deadline) (declare (ignore stream fd deadline)) ;; This situation means that the lisp set our fd to non-blocking mode, ;; and streams.lisp didn't know how to undo that. (warn "non-blocking stream encountered unexpectedly")) ;;; Encrypted PEM files support ;;; ;; based on http://www.openssl.org/docs/ssl/SSL_CTX_set_default_passwd_cb.html (defvar *pem-password* "" "The callback registered with SSL_CTX_set_default_passwd_cb will use this value.") ;; The callback itself (cffi:defcallback pem-password-callback :int ((buf :pointer) (size :int) (rwflag :int) (unused :pointer)) (declare (ignore rwflag unused)) (let* ((password-str (coerce *pem-password* 'base-string)) (tmp (cffi:foreign-string-alloc password-str))) (cffi:foreign-funcall "strncpy" :pointer buf :pointer tmp :int size) (cffi:foreign-string-free tmp) (setf (cffi:mem-ref buf :char (1- size)) 0) (cffi:foreign-funcall "strlen" :pointer buf :int))) ;; The macro to be used by other code to provide password ;; when loading PEM file. (defmacro with-pem-password ((password) &body body) `(let ((*pem-password* (or ,password ""))) ,@body)) ;;; Initialization ;;; (defun init-prng (seed-byte-sequence) (let* ((length (length seed-byte-sequence)) (buf (cffi-sys::make-shareable-byte-vector length))) (dotimes (i length) (setf (elt buf i) (elt seed-byte-sequence i))) (cffi-sys::with-pointer-to-vector-data (ptr buf) (rand-seed ptr length)))) (defun ssl-ctx-set-session-cache-mode (ctx mode) (ssl-ctx-ctrl ctx +SSL_CTRL_SET_SESS_CACHE_MODE+ mode (cffi:null-pointer))) (defun SSL-set-tlsext-host-name (ctx hostname) (ssl-ctrl ctx 55 #|SSL_CTRL_SET_TLSEXT_HOSTNAME|# 0 #|TLSEXT_NAMETYPE_host_name|# hostname)) (defvar *locks*) (defconstant +CRYPTO-LOCK+ 1) (defconstant +CRYPTO-UNLOCK+ 2) (defconstant +CRYPTO-READ+ 4) (defconstant +CRYPTO-WRITE+ 8) ;; zzz as of early 2011, bxthreads is totally broken on SBCL wrt. explicit ;; locking of recursive locks. with-recursive-lock works, but acquire/release ;; don't. Hence we use non-recursize locks here (but can use a recursive ;; lock for the global lock). (cffi:defcallback locking-callback :void ((mode :int) (n :int) (file :pointer) ;; could be (file :string), but we don't use FILE, so avoid the conversion (line :int)) (declare (ignore file line)) ;; (assert (logtest mode (logior +CRYPTO-READ+ +CRYPTO-WRITE+))) (let ((lock (elt *locks* n))) (cond ((logtest mode +CRYPTO-LOCK+) (bt:acquire-lock lock)) ((logtest mode +CRYPTO-UNLOCK+) (bt:release-lock lock)) (t (error "fell through"))))) (defvar *threads* (trivial-garbage:make-weak-hash-table :weakness :key)) (defvar *thread-counter* 0) (defparameter *global-lock* (bordeaux-threads:make-recursive-lock "SSL initialization")) ;; zzz BUG: On a 32-bit system and under non-trivial load, this counter ;; is likely to wrap in less than a year. (cffi:defcallback threadid-callback :unsigned-long () (bordeaux-threads:with-recursive-lock-held (*global-lock*) (let ((self (bt:current-thread))) (or (gethash self *threads*) (setf (gethash self *threads*) (incf *thread-counter*)))))) (defvar *ssl-check-verify-p* :unspecified) (defun initialize (&key (method 'ssl-v23-method) rand-seed) (setf *locks* (loop repeat (crypto-num-locks) collect (bt:make-lock))) (crypto-set-locking-callback (cffi:callback locking-callback)) (crypto-set-id-callback (cffi:callback threadid-callback)) (setf *bio-lisp-method* (make-bio-lisp-method)) (ssl-load-error-strings) (ssl-library-init) (when rand-seed (init-prng rand-seed)) (setf *ssl-check-verify-p* :unspecified) (setf *ssl-global-method* (funcall method)) (setf *ssl-global-context* (ssl-ctx-new *ssl-global-method*)) (ssl-ctx-set-session-cache-mode *ssl-global-context* 3) (ssl-ctx-set-default-passwd-cb *ssl-global-context* (cffi:callback pem-password-callback)) (ssl-ctx-set-tmp-rsa-callback *ssl-global-context* (cffi:callback tmp-rsa-callback))) (defun ensure-initialized (&key (method 'ssl-v23-method) (rand-seed nil)) "In most cases you do *not* need to call this function, because it is called automatically by all other functions. The only reason to call it explicitly is to supply the RAND-SEED parameter. In this case do it before calling any other functions. Just leave the default value for the METHOD parameter. RAND-SEED is an octet sequence to initialize OpenSSL random number generator. On many platforms, including Linux and Windows, it may be leaved NIL (default), because OpenSSL initializes the random number generator from OS specific service. But for example on Solaris it may be necessary to supply this value. The minimum length required by OpenSSL is 128 bits. See ttp://www.openssl.org/support/faq.html#USER1 for details. Hint: do not use Common Lisp RANDOM function to generate the RAND-SEED, because the function usually returns predictable values." (bordeaux-threads:with-recursive-lock-held (*global-lock*) (unless (ssl-initialized-p) (initialize :method method :rand-seed rand-seed)) (unless *bio-lisp-method* (setf *bio-lisp-method* (make-bio-lisp-method))))) (defun use-certificate-chain-file (certificate-chain-file) "Loads a PEM encoded certificate chain file CERTIFICATE-CHAIN-FILE and adds the chain to global context. The certificates must be sorted starting with the subject's certificate (actual client or server certificate), followed by intermediate CA certificates if applicable, and ending at the highest level (root) CA. Note: the RELOAD function clears the global context and in particular the loaded certificate chain." (ensure-initialized) (ssl-ctx-use-certificate-chain-file *ssl-global-context* certificate-chain-file)) (defun reload () (if *ssl-global-context* (ssl-ctx-free *ssl-global-context*)) (cffi:load-foreign-library 'libssl) (cffi:load-foreign-library 'libeay32) (setf *ssl-global-context* nil) (setf *ssl-global-method* nil) (setf *tmp-rsa-key-512* nil) (setf *tmp-rsa-key-1024* nil)) cl+ssl-20170630-git/src/package.lisp000066400000000000000000000031171311543060700170070ustar00rootroot00000000000000;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. #+xcvb (module (:depends-on ((:when (:featurep :sbcl) (:require :sb-posix))))) (in-package :cl-user) (defpackage :cl+ssl (:use :common-lisp :trivial-gray-streams) (:export #:*default-cipher-list* #:ensure-initialized #:reload #:stream-fd #:make-ssl-client-stream #:make-ssl-server-stream #:use-certificate-chain-file #:random-bytes #:ssl-check-verify-p #:ssl-load-global-verify-locations #:ssl-set-global-default-verify-paths #:ssl-error-verify #:ssl-error-stream #:ssl-error-code #:ssl-error-initialize #:ssl-ctx-free #:with-pem-password #:+ssl-verify-none+ #:+ssl-verify-peer+ #:+ssl-verify-fail-if-no-peer-cert+ #:+ssl-verify-client-once+ #:+ssl-op-no-sslv2+ #:+ssl-op-no-sslv3+ #:+ssl-op-no-tlsv1+ #:+ssl-op-no-tlsv1-1+ #:+ssl-op-no-tlsv1-2+ #:+ssl-sess-cache-off+ #:+ssl-sess-cache-client+ #:+ssl-sess-cache-server+ #:+ssl-sess-cache-both+ #:+ssl-sess-cache-no-auto-clear+ #:+ssl-sess-cache-no-internal-lookup+ #:+ssl-sess-cache-no-internal-store+ #:+ssl-sess-cache-no-internal+ #:make-context #:with-global-context)) cl+ssl-20170630-git/src/random.lisp000066400000000000000000000027251311543060700167000ustar00rootroot00000000000000#+xcvb (module (:depends-on ("package" "conditions" "ffi" (:cond ((:featurep :clisp) "ffi-buffer-clisp") (t "ffi-buffer")) "ffi-buffer-all"))) (in-package :cl+ssl) (defun random-bytes (count) "Generates COUNT cryptographically strong pseudo-random bytes. Returns the bytes as a SIMPLE-ARRAY with ELEMENT-TYPE '(UNSIGNED-BYTE 8). Signals an ERROR in case of problems, for example when the OpenSSL random number generator has not been seeded with enough randomness to ensure an unpredictable byte sequence." (let* ((result (make-array count :element-type '(unsigned-byte 8))) (buf (make-buffer count)) (ret (with-pointer-to-vector-data (ptr buf) (rand-bytes ptr count)))) (when (/= 1 ret) (error "RANDOM-BYTES failed: error reported by the OpenSSL RAND_bytes function. ~A." (format-ssl-error-queue nil (read-ssl-error-queue)))) (s/b-replace result buf))) ;; TODO: Should we define random-specific constants and condition classes for ;; RAND_F_RAND_GET_RAND_METHOD, RAND_F_SSLEAY_RAND_BYTES, RAND_R_PRNG_NOT_SEEDED ;; (defined in the rand.h file of the OpenSSl sources)? ;; Where to place these constants/condtitions, here or in the conditions.lisp? ;; On the other hand, those constants are just numbers defined for C, ;; for now we jsut report human readable strings, without possibility ;; to distinguish these error causes programmatically. cl+ssl-20170630-git/src/reload.lisp000066400000000000000000000042701311543060700166630ustar00rootroot00000000000000;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. ;;; We do this in an extra file so that it happens ;;; - after the asd file has been loaded, so that users can ;;; customize *libssl-pathname* between loading the asd and LOAD-OPing ;;; the actual sources ;;; - before ssl.lisp is loaded, which needs the library at compilation ;;; time on some implemenations ;;; - but not every time ffi.lisp is re-loaded as would happen if we ;;; put this directly into ffi.lisp #+xcvb (module (:depends-on ("package"))) (in-package :cl+ssl) ;; OpenBSD needs to load libcrypto before libssl #+openbsd (progn (cffi:define-foreign-library libcrypto (:openbsd "libcrypto.so")) (cffi:use-foreign-library libcrypto)) (cffi:define-foreign-library libssl (:windows (:or "libssl32.dll" "ssleay32.dll")) (:darwin (:or "libssl.dylib" "/usr/lib/libssl.dylib")) (:solaris (:or "/lib/64/libssl.so" "libssl.so.0.9.8" "libssl.so" "libssl.so.4")) ;; Unlike some other systems, OpenBSD linker, ;; when passed library name without versions at the end, ;; will locate the library with highest macro.minor version, ;; so we can just use just "libssl.so". ;; More info at https://github.com/cl-plus-ssl/cl-plus-ssl/pull/2. (:openbsd "libssl.so") ((and :unix (not :cygwin)) (:or "libssl.so.1.0.2" "libssl.so.1.0.1l" "libssl.so.1.0.1e" "libssl.so.1.0.1j" "libssl.so.1.0.1" "libssl.so.1.0.0q" "libssl.so.1.0.0" "libssl.so.0.9.8ze" "libssl.so.0.9.8" "libssl.so" "libssl.so.4" "libssl.so.10")) (:cygwin "cygssl-1.0.0.dll") (t (:default "libssl3"))) (cffi:use-foreign-library libssl) (cffi:define-foreign-library libeay32 (:windows "libeay32.dll")) (cffi:use-foreign-library libeay32) cl+ssl-20170630-git/src/streams.lisp000066400000000000000000000375661311543060700171110ustar00rootroot00000000000000;;; Copyright (C) 2001, 2003 Eric Marsden ;;; Copyright (C) 2005 David Lichteblau ;;; Copyright (C) 2007 Pixel // pinterface ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt." ;;; ;;; See LICENSE for details. #+xcvb (module (:depends-on ("package" "conditions" "ffi" (:cond ((:featurep :clisp) "ffi-buffer-clisp") (t "ffi-buffer")) "ffi-buffer-all"))) (eval-when (:compile-toplevel) (declaim (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0)))) (in-package :cl+ssl) ;; Default Cipher List (defvar *default-cipher-list* "ALL") (defclass ssl-stream (trivial-gray-stream-mixin fundamental-binary-input-stream fundamental-binary-output-stream) ((ssl-stream-socket :initarg :socket :accessor ssl-stream-socket) (close-callback :initarg :close-callback :accessor ssl-close-callback) (handle :initform nil :accessor ssl-stream-handle) (deadline :initform nil :initarg :deadline :accessor ssl-stream-deadline) (output-buffer :initform (make-buffer +initial-buffer-size+) :accessor ssl-stream-output-buffer) (output-pointer :initform 0 :accessor ssl-stream-output-pointer) (input-buffer :initform (make-buffer +initial-buffer-size+) :accessor ssl-stream-input-buffer) (peeked-byte :initform nil :accessor ssl-stream-peeked-byte))) (defmethod print-object ((object ssl-stream) stream) (print-unreadable-object (object stream :type t) (format stream "for ~A" (ssl-stream-socket object)))) (defclass ssl-server-stream (ssl-stream) ((certificate :initarg :certificate :accessor ssl-stream-certificate) (key :initarg :key :accessor ssl-stream-key))) (defmethod stream-element-type ((stream ssl-stream)) '(unsigned-byte 8)) (defmethod close ((stream ssl-stream) &key abort) (cond ((ssl-stream-handle stream) (unless abort (force-output stream)) (ssl-free (ssl-stream-handle stream)) (setf (ssl-stream-handle stream) nil) (when (streamp (ssl-stream-socket stream)) (close (ssl-stream-socket stream))) (when (ssl-close-callback stream) (funcall (ssl-close-callback stream))) t) (t nil))) (defmethod open-stream-p ((stream ssl-stream)) (and (ssl-stream-handle stream) t)) (defmethod stream-listen ((stream ssl-stream)) (or (ssl-stream-peeked-byte stream) (setf (ssl-stream-peeked-byte stream) (let* ((buf (ssl-stream-input-buffer stream)) (handle (ssl-stream-handle stream)) (*blockp* nil) ;; for the Lisp-BIO (n (with-pointer-to-vector-data (ptr buf) (nonblocking-ssl-funcall stream handle #'ssl-read handle ptr 1)))) (and (> n 0) (buffer-elt buf 0)))))) (defmethod stream-read-byte ((stream ssl-stream)) (or (prog1 (ssl-stream-peeked-byte stream) (setf (ssl-stream-peeked-byte stream) nil)) (handler-case (let ((buf (ssl-stream-input-buffer stream)) (handle (ssl-stream-handle stream))) (with-pointer-to-vector-data (ptr buf) (ensure-ssl-funcall stream handle #'ssl-read handle ptr 1)) (buffer-elt buf 0)) (ssl-error-zero-return () ;SSL_read returns 0 on end-of-file :eof)))) (defmethod stream-read-sequence ((stream ssl-stream) seq start end &key) (when (and (< start end) (ssl-stream-peeked-byte stream)) (setf (elt seq start) (ssl-stream-peeked-byte stream)) (setf (ssl-stream-peeked-byte stream) nil) (incf start)) (let ((buf (ssl-stream-input-buffer stream)) (handle (ssl-stream-handle stream))) (loop for length = (min (- end start) (buffer-length buf)) while (plusp length) do (handler-case (let ((read-bytes (with-pointer-to-vector-data (ptr buf) (ensure-ssl-funcall stream handle #'ssl-read handle ptr length)))) (s/b-replace seq buf :start1 start :end1 (+ start read-bytes)) (incf start read-bytes)) (ssl-error-zero-return () ;SSL_read returns 0 on end-of-file (return)))) ;; fixme: kein out-of-file wenn (zerop start)? start)) (defmethod stream-write-byte ((stream ssl-stream) b) (let ((buf (ssl-stream-output-buffer stream))) (when (eql (buffer-length buf) (ssl-stream-output-pointer stream)) (force-output stream)) (setf (buffer-elt buf (ssl-stream-output-pointer stream)) b) (incf (ssl-stream-output-pointer stream))) b) (defmethod stream-write-sequence ((stream ssl-stream) seq start end &key) (let ((buf (ssl-stream-output-buffer stream))) (when (> (+ (- end start) (ssl-stream-output-pointer stream)) (buffer-length buf)) ;; not enough space left? flush buffer. (force-output stream) ;; still doesn't fit? (while (> (- end start) (buffer-length buf)) (b/s-replace buf seq :start2 start) (incf start (buffer-length buf)) (setf (ssl-stream-output-pointer stream) (buffer-length buf)) (force-output stream))) (b/s-replace buf seq :start1 (ssl-stream-output-pointer stream) :start2 start :end2 end) (incf (ssl-stream-output-pointer stream) (- end start))) seq) (defmethod stream-finish-output ((stream ssl-stream)) (stream-force-output stream)) (defmethod stream-force-output ((stream ssl-stream)) (let ((buf (ssl-stream-output-buffer stream)) (fill-ptr (ssl-stream-output-pointer stream)) (handle (ssl-stream-handle stream))) (when (plusp fill-ptr) (unless handle (error "output operation on closed SSL stream")) (with-pointer-to-vector-data (ptr buf) (ensure-ssl-funcall stream handle #'ssl-write handle ptr fill-ptr)) (setf (ssl-stream-output-pointer stream) 0)))) #+(and clozure-common-lisp (not windows)) (defun install-nonblock-flag (fd) (ccl::fd-set-flags fd (logior (ccl::fd-get-flags fd) #.(read-from-string "#$O_NONBLOCK")))) ;; read-from-string is necessary because ;; CLISP and perhaps other Lisps are confused ;; by #$, signaling"undefined dispatch character $", ;; even though the defun in conditionalized by ;; #+clozure-common-lisp #+(and sbcl (not win32)) (defun install-nonblock-flag (fd) (sb-posix:fcntl fd sb-posix::f-setfl (logior (sb-posix:fcntl fd sb-posix::f-getfl) sb-posix::o-nonblock))) #-(or (and clozure-common-lisp (not windows)) sbcl) (defun install-nonblock-flag (fd) (declare (ignore fd))) #+(and sbcl win32) (defun install-nonblock-flag (fd) (when (boundp 'sockint::fionbio) (sockint::ioctl fd sockint::fionbio 1))) ;;; interface functions ;;; (defun install-handle-and-bio (stream handle socket unwrap-stream-p) (setf (ssl-stream-handle stream) handle) (when unwrap-stream-p (let ((fd (stream-fd socket))) (when fd (setf socket fd)))) (etypecase socket (integer (install-nonblock-flag socket) (ssl-set-fd handle socket)) (stream (ssl-set-bio handle (bio-new-lisp) (bio-new-lisp)))) ;; The below call setting +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ mode ;; existed since commit 5bd5225. ;; It is implemented wrong - ssl-ctx-ctrl expects ;; a context as the first parameter, not handle. ;; It was lucky to not crush on Linux and Windows, ;; untill crash was detedcted on OpenBSD + LibreSSL. ;; See https://github.com/cl-plus-ssl/cl-plus-ssl/pull/42. ;; We keep this code commented but not removed because ;; we don't know what David Lichteblau meant when ;; added this - maybe he has some idea? ;; (Although modifying global context is a bad ;; thing to do for install-handle-and-bio function, ;; also we don't see a need for movable buffer - ;; we don't repeat calls to ssl functions with ;; moved buffer). ;; ;; (ssl-ctx-ctrl handle ;; +SSL_CTRL_MODE+ ;; +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ ;; (cffi:null-pointer)) socket) (defun install-key-and-cert (handle key certificate) (when key (unless (eql 1 (ssl-use-rsa-privatekey-file handle key +ssl-filetype-pem+)) (error 'ssl-error-initialize :reason (format nil "Can't load RSA private key file ~A" key)))) (when certificate (unless (eql 1 (ssl-use-certificate-file handle certificate +ssl-filetype-pem+)) (error 'ssl-error-initialize :reason (format nil "Can't load certificate ~A" certificate))))) (defun x509-certificate-names (x509-certificate) (unless (cffi:null-pointer-p x509-certificate) (cffi:with-foreign-pointer (buf 1024) (let ((issuer-name (x509-get-issuer-name x509-certificate)) (subject-name (x509-get-subject-name x509-certificate))) (values (unless (cffi:null-pointer-p issuer-name) (x509-name-oneline issuer-name buf 1024) (cffi:foreign-string-to-lisp buf)) (unless (cffi:null-pointer-p subject-name) (x509-name-oneline subject-name buf 1024) (cffi:foreign-string-to-lisp buf))))))) (defmethod ssl-stream-handle ((stream flexi-streams:flexi-stream)) (ssl-stream-handle (flexi-streams:flexi-stream-stream stream))) (defun ssl-stream-x509-certificate (ssl-stream) (ssl-get-peer-certificate (ssl-stream-handle ssl-stream))) (defun ssl-load-global-verify-locations (&rest pathnames) "PATHNAMES is a list of pathnames to PEM files containing server and CA certificates. Install these certificates to use for verifying on all SSL connections. After RELOAD, you need to call this again." (ensure-initialized) (dolist (path pathnames) (let ((namestring (namestring (truename path)))) (cffi:with-foreign-strings ((cafile namestring)) (unless (eql 1 (ssl-ctx-load-verify-locations *ssl-global-context* cafile (cffi:null-pointer))) (error "ssl-ctx-load-verify-locations failed.")))))) (defun ssl-set-global-default-verify-paths () "Load the system default verification certificates. After RELOAD, you need to call this again." (ensure-initialized) (unless (eql 1 (ssl-ctx-set-default-verify-paths *ssl-global-context*)) (error "ssl-ctx-set-default-verify-paths failed."))) (defun ssl-check-verify-p () "Return true if SSL connections will error if the certificate doesn't verify." (and *ssl-check-verify-p* (not (eq *ssl-check-verify-p* :unspecified)))) (defun (setf ssl-check-verify-p) (check-verify-p) "If CHECK-VERIFY-P is true, signal connection errors if the server certificate doesn't verify." (setf *ssl-check-verify-p* (not (null check-verify-p)))) (defun ssl-verify-init (&key (verify-depth nil) (verify-locations nil)) (check-type verify-depth (or null integer)) (ensure-initialized) (when verify-depth (ssl-ctx-set-verify-depth *ssl-global-context* verify-depth)) (when verify-locations (apply #'ssl-load-global-verify-locations verify-locations) ;; This makes (setf (ssl-check-verify) nil) persistent (unless (null *ssl-check-verify-p*) (setf (ssl-check-verify-p) t)) t)) (defun ssl-stream-check-verify (ssl-stream) (let* ((handle (ssl-stream-handle ssl-stream)) (err (ssl-get-verify-result handle))) (unless (eql err 0) (error 'ssl-error-verify :stream ssl-stream :error-code err)))) (defun handle-external-format (stream ef) (if ef (flexi-streams:make-flexi-stream stream :external-format ef) stream)) (defmacro with-new-ssl ((var) &body body) (alexandria:with-gensyms (ssl) `(let* ((,ssl (ssl-new *ssl-global-context*)) (,var ,ssl)) (when (cffi:null-pointer-p ,ssl) (error 'ssl-error-call :message "Unable to create SSL structure" :queue (read-ssl-error-queue))) (handler-bind ((error (lambda (_) (declare (ignore _)) (ssl-free ,ssl)))) ,@body)))) ;; fixme: free the context when errors happen in this function (defun make-ssl-client-stream (socket &key certificate key password (method 'ssl-v23-method) external-format close-callback (unwrap-stream-p t) (cipher-list *default-cipher-list*) hostname) "Returns an SSL stream for the client socket descriptor SOCKET. CERTIFICATE is the path to a file containing the PEM-encoded certificate for your client. KEY is the path to the PEM-encoded key for the client, which may be associated with the passphrase PASSWORD. HOSTNAME if specified, will be sent by client during TLS negotiation, according to the Server Name Indication (SNI) extension to the TLS. When server handles several domain names, this extension enables the server to choose certificate for right domain." (ensure-initialized :method method) (let ((stream (make-instance 'ssl-stream :socket socket :close-callback close-callback))) (with-new-ssl (handle) (if hostname (cffi:with-foreign-string (chostname hostname) (ssl-set-tlsext-host-name handle chostname))) (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p)) (ssl-set-connect-state handle) (when (zerop (ssl-set-cipher-list handle cipher-list)) (error 'ssl-error-initialize :reason "Can't set SSL cipher list")) (with-pem-password (password) (install-key-and-cert handle key certificate)) (ensure-ssl-funcall stream handle #'ssl-connect handle) (when (ssl-check-verify-p) (ssl-stream-check-verify stream)) (handle-external-format stream external-format)))) ;; fixme: free the context when errors happen in this function (defun make-ssl-server-stream (socket &key certificate key password (method 'ssl-v23-method) external-format close-callback (unwrap-stream-p t) (cipher-list *default-cipher-list*)) "Returns an SSL stream for the server socket descriptor SOCKET. CERTIFICATE is the path to a file containing the PEM-encoded certificate for your server. KEY is the path to the PEM-encoded key for the server, which may be associated with the passphrase PASSWORD." (ensure-initialized :method method) (let ((stream (make-instance 'ssl-server-stream :socket socket :close-callback close-callback :certificate certificate :key key))) (with-new-ssl (handle) (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p)) (ssl-set-accept-state handle) (when (zerop (ssl-set-cipher-list handle cipher-list)) (error 'ssl-error-initialize :reason "Can't set SSL cipher list")) (with-pem-password (password) (install-key-and-cert handle key certificate)) (ensure-ssl-funcall stream handle #'ssl-accept handle) (handle-external-format stream external-format)))) #+openmcl (defmethod stream-deadline ((stream ccl::basic-stream)) (ccl::ioblock-deadline (ccl::stream-ioblock stream t))) #+openmcl (defmethod stream-deadline ((stream t)) nil) (defgeneric stream-fd (stream)) (defmethod stream-fd (stream) stream) #+sbcl (defmethod stream-fd ((stream sb-sys:fd-stream)) (sb-sys:fd-stream-fd stream)) #+cmu (defmethod stream-fd ((stream system:fd-stream)) (system:fd-stream-fd stream)) #+openmcl (defmethod stream-fd ((stream ccl::basic-stream)) (ccl::ioblock-device (ccl::stream-ioblock stream t))) #+clisp (defmethod stream-fd ((stream stream)) ;; sockets appear to be direct instances of STREAM (ext:stream-handles stream)) #+ecl (defmethod stream-fd ((stream two-way-stream)) (si:file-stream-fd (two-way-stream-input-stream stream))) cl+ssl-20170630-git/ssl-verify-test.lisp000066400000000000000000000143161311543060700177100ustar00rootroot00000000000000;;; Copyright (C) 2011 David Lichteblau ;;; ;;; See LICENSE for details. #+xcvb (module (:depends-on ("package"))) (in-package :cl+ssl) ;; from cl+ssl/example.lisp (defun read-line-crlf-2 (stream &optional eof-error-p) (let ((s (make-string-output-stream))) (loop for empty = t then nil for c = (read-char stream eof-error-p nil) while (and c (not (eql c #\return))) do (unless (eql c #\newline) (write-char c s)) finally (return (if empty nil (get-output-stream-string s)))))) (defun write-ssl-certificate-names (ssl-stream &optional (output-stream t)) (let* ((ssl (ssl-stream-handle ssl-stream)) (cert (ssl-get-peer-certificate ssl))) (unless (cffi:null-pointer-p cert) (unwind-protect (multiple-value-bind (issuer subject) (x509-certificate-names cert) (format output-stream " issuer: ~a~% subject: ~a~%" issuer subject)) (x509-free cert))))) ;; from cl+ssl/example.lisp (defun test-https-client-2 (host &key (port 443) show-text-p) (let* ((deadline (+ (get-internal-real-time) (* 3 internal-time-units-per-second))) (socket (ccl:make-socket :address-family :internet :connect :active :type :stream :remote-host host :remote-port port ;; :local-host (resolve-hostname local-host) ;; :local-port local-port :deadline deadline)) https) (unwind-protect (handler-bind ((ssl-error-verify (lambda (c) (write-ssl-certificate-names (ssl-error-stream c))))) (setf https (cl+ssl:make-ssl-client-stream socket :unwrap-stream-p t :external-format '(:iso-8859-1 :eol-style :lf))) (write-ssl-certificate-names https) (format https "GET / HTTP/1.0~%Host: ~a~%~%" host) (force-output https) (loop :for line = (read-line-crlf-2 https nil) for cnt from 0 :while line :do (when show-text-p (format t "HTTPS> ~a~%" line)) finally (return cnt))) (if https (close https) (close socket))))) (defparameter *rayservers-ca-certificate-pem-file* "rayservers-ca-certificate.pem") (defparameter *rayservers-ca-certificate-path* (merge-pathnames *rayservers-ca-certificate-pem-file* (asdf:system-source-directory :cl+ssl))) (defparameter *rayservers-ca-certificate-pem* "-----BEGIN CERTIFICATE----- MIIElTCCA32gAwIBAgIJALoXNnj+yvJCMA0GCSqGSIb3DQEBBQUAMIGNMQswCQYD VQQGEwJQQTELMAkGA1UECBMCTkExFDASBgNVBAcTC1BhbmFtYSBDaXR5MRgwFgYD VQQKEw9SYXlzZXJ2ZXJzIEdtYkgxGjAYBgNVBAMTEWNhLnJheXNlcnZlcnMuY29t MSUwIwYJKoZIhvcNAQkBFhZzdXBwb3J0QHJheXNlcnZlcnMuY29tMB4XDTA5MTAx OTE3MzgyMFoXDTE5MTAxNzE3MzgyMFowgY0xCzAJBgNVBAYTAlBBMQswCQYDVQQI EwJOQTEUMBIGA1UEBxMLUGFuYW1hIENpdHkxGDAWBgNVBAoTD1JheXNlcnZlcnMg R21iSDEaMBgGA1UEAxMRY2EucmF5c2VydmVycy5jb20xJTAjBgkqhkiG9w0BCQEW FnN1cHBvcnRAcmF5c2VydmVycy5jb20wggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAw ggEKAoIBAQC9rNsCCM+TNp6xDk2yxhXQOStmPTd0txFyduNAj02/nLZV4eq0ZS5n xXBE6l3MYIMBMV3BgKiy7LsdiRJeZ5HdsV/HRZzXCQI+k4acBjlRC1ZdWMNsIR+H QUVx2y0wgp+QpcMrgBQZdPI7PobnXCZ6+Fmc50kM7xbIsoWZUzQDpRtUymgOhnnT 4TSb1/XufFHHhDMReRA7s3Co911hzcnZJqL9gFWULlB/RI2ZeVbkp0K4lUXyMZ/R fnOtCdAA+TkQcpzoyBETV9p5MO8KBOPBskvyGYqVcIZNuxwfC2uoKx0s5b6eMRKR 54B4mB/hIi7i0uGjzuAZdt5iDXQHYaM3AgMBAAGjgfUwgfIwHQYDVR0OBBYEFOyu Fp80LSc1gwnq5rghs/P8bMgrMIHCBgNVHSMEgbowgbeAFOyuFp80LSc1gwnq5rgh s/P8bMgroYGTpIGQMIGNMQswCQYDVQQGEwJQQTELMAkGA1UECBMCTkExFDASBgNV BAcTC1BhbmFtYSBDaXR5MRgwFgYDVQQKEw9SYXlzZXJ2ZXJzIEdtYkgxGjAYBgNV BAMTEWNhLnJheXNlcnZlcnMuY29tMSUwIwYJKoZIhvcNAQkBFhZzdXBwb3J0QHJh eXNlcnZlcnMuY29tggkAuhc2eP7K8kIwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0B AQUFAAOCAQEAqScS+A2Hajjb+jTKQ19LVPzTpRYo1Jz0SPtzGO91n0efYeRJD5hV tU+57zGSlUDszARvB+sxzLdJTItK+wEpDM8pLtwUT/VPrRKOoOUBkKBshcTD4HmI k8uJlNed0QQLP41hFjr+mYd7WM+N5LtFMQAUBMUN6dzEqQIx69EnIoVp0KB8kDwW /QK5ogKY0g8DmRTFiV036bHQH93kLzyV6FNAldO8vBDqcTeru/uU2Kcn6a8YOfO1 T6MVYory7prWbBaGPKsGw0VgrV9OGbxhbw9EOEYSOgdejvbi9VhgMvEpDYFN7Hnq 0wiHJq5jKECf3bwRe9uVzVMrIeCap/r2uA== -----END CERTIFICATE-----") (defun write-rayservers-certificate-pem () (with-open-file (s *rayservers-ca-certificate-path* :direction :output :if-exists :supersede :if-does-not-exist :create) (write-string *rayservers-ca-certificate-pem* s) *rayservers-ca-certificate-path*)) (defun install-rayservers-ca-certificate () (let ((path (write-rayservers-certificate-pem))) (ssl-load-global-verify-locations path))) (defun test-loom-client (&optional show-text-p) (test-https-client-2 "secure.loom.cc" :show-text-p show-text-p)) (defun test-yahoo-client (&optional show-text-p) (test-https-client-2 "yahoo.com" :show-text-p show-text-p)) (defmacro expecting-no-errors (&body body) `(handler-case (progn ,@body) (error (c) (error "Got an unexpected error: ~a" c)))) (defmacro expecting-error ((type) &body body) `(let ((got-error-p nil)) (handler-case (progn ,@body) (error (c) (unless (typep c ',type) (error "Got an unexpected error type: ~a" c)) (setf got-error-p t))) (unless got-error-p (error "Did not get expected error.")))) (defun test-verify (&optional quietly) (let ((*standard-output* ;; test-https-client-2 prints the certificate names (if quietly (make-broadcast-stream) *standard-output*))) (expecting-no-errors (reload) (test-loom-client) (test-yahoo-client) (setf (ssl-check-verify-p) t)) ;; The Mac appears to have no way to get rid of the default CA certificates ;; #+darwin-host is only true in Clozure Common Lisp running on a Mac, ;; So this test will fail in SBCL on a Mac #-darwin-host (expecting-error (ssl-error-verify) (test-yahoo-client)) #+darwin-host (expecting-no-errors (test-yahoo-client)) (expecting-error (ssl-error-verify) (test-loom-client)) (expecting-no-errors (install-rayservers-ca-certificate) (test-loom-client)) (expecting-no-errors (ssl-set-global-default-verify-paths) (test-yahoo-client)))) cl+ssl-20170630-git/test.lisp000066400000000000000000000311021311543060700155770ustar00rootroot00000000000000;;; Copyright (C) 2008 David Lichteblau ;;; See LICENSE for details. #| (load "test.lisp") |# (defpackage :ssl-test (:use :cl)) (in-package :ssl-test) (defvar *port* 8080) (defvar *cert* "/home/david/newcert.pem") (defvar *key* "/home/david/newkey.pem") (eval-when (:compile-toplevel :load-toplevel :execute) (asdf:operate 'asdf:load-op :trivial-sockets) (asdf:operate 'asdf:load-op :bordeaux-threads)) (defparameter *tests* '()) (defvar *sockets* '()) (defvar *sockets-lock* (bordeaux-threads:make-lock)) (defun record-socket (socket) (unless (integerp socket) (bordeaux-threads:with-lock-held (*sockets-lock*) (push socket *sockets*))) socket) (defun close-socket (socket &key abort) (if (streamp socket) (close socket :abort abort) (trivial-sockets:close-server socket))) (defun check-sockets () (let ((failures nil)) (bordeaux-threads:with-lock-held (*sockets-lock*) (dolist (socket *sockets*) (when (close-socket socket :abort t) (push socket failures))) (setf *sockets* nil)) #-sbcl ;fixme (when failures (error "failed to close sockets properly:~{ ~A~%~}" failures)))) (defmacro deftest (name &body body) `(progn (defun ,name () (format t "~%----- ~A ----------------------------~%" ',name) (handler-case (progn ,@body (check-sockets) (format t "===== [OK] ~A ====================~%" ',name) t) (error (c) (when (typep c 'trivial-sockets:socket-error) (setf c (trivial-sockets:socket-nested-error c))) (format t "~%===== [FAIL] ~A: ~A~%" ',name c) (handler-case (check-sockets) (error (c) (format t "muffling follow-up error ~A~%" c))) nil))) (push ',name *tests*))) (defun run-all-tests () (unless (probe-file *cert*) (error "~A not found" *cert*)) (unless (probe-file *key*) (error "~A not found" *key*)) (let ((n 0) (nok 0)) (dolist (test (reverse *tests*)) (when (funcall test) (incf nok)) (incf n)) (format t "~&passed ~D/~D tests~%" nok n))) (define-condition quit (condition) ()) (defparameter *please-quit* t) (defun make-test-thread (name init main &rest args) "Start a thread named NAME, wait until it has funcalled INIT with ARGS as arguments, then continue while the thread concurrently funcalls MAIN with INIT's return values as arguments." (let ((cv (bordeaux-threads:make-condition-variable)) (lock (bordeaux-threads:make-lock name)) ;; redirect io manually, because swan's global redirection isn't as ;; global as one might hope (out *terminal-io*) (init-ok nil)) (bordeaux-threads:with-lock-held (lock) (setf *please-quit* nil) (prog1 (bordeaux-threads:make-thread (lambda () (flet ((notify () (bordeaux-threads:with-lock-held (lock) (bordeaux-threads:condition-notify cv)))) (let ((*terminal-io* out) (*standard-output* out) (*trace-output* out) (*error-output* out)) (handler-case (let ((values (multiple-value-list (apply init args)))) (setf init-ok t) (notify) (apply main values)) (quit () (notify) t) (error (c) (when (typep c 'trivial-sockets:socket-error) (setf c (trivial-sockets:socket-nested-error c))) (format t "aborting test thread ~A: ~A" name c) (notify) nil))))) :name name) (bordeaux-threads:condition-wait cv lock) (unless init-ok (error "failed to start background thread")))))) (defmacro with-thread ((name init main &rest args) &body body) `(invoke-with-thread (lambda () ,@body) ,name ,init ,main ,@args)) (defun invoke-with-thread (body name init main &rest args) (let ((thread (apply #'make-test-thread name init main args))) (unwind-protect (funcall body) (setf *please-quit* t) (loop for delay = 0.0001 then (* delay 2) while (and (< delay 0.5) (bordeaux-threads:thread-alive-p thread)) do (sleep delay)) (when (bordeaux-threads:thread-alive-p thread) (format t "~&thread doesn't want to quit, killing it~%") (force-output) (bordeaux-threads:interrupt-thread thread (lambda () (error 'quit))) (loop for delay = 0.0001 then (* delay 2) while (bordeaux-threads:thread-alive-p thread) do (sleep delay)))))) (defun init-server (&key (unwrap-stream-p t)) (format t "~&SSL server listening on port ~d~%" *port*) (values (record-socket (trivial-sockets:open-server :port *port*)) unwrap-stream-p)) (defun test-server (listening-socket unwrap-stream-p) (format t "~&SSL server accepting...~%") (unwind-protect (let* ((socket (record-socket (trivial-sockets:accept-connection listening-socket :element-type '(unsigned-byte 8)))) (callback nil)) (when (eq unwrap-stream-p :caller) (setf callback (let ((s socket)) (lambda () (close-socket s)))) (setf socket (cl+ssl:stream-fd socket)) (setf unwrap-stream-p nil)) (let ((client (record-socket (cl+ssl:make-ssl-server-stream socket :unwrap-stream-p unwrap-stream-p :close-callback callback :external-format :iso-8859-1 :certificate *cert* :key *key*)))) (unwind-protect (loop for line = (prog2 (when *please-quit* (return)) (read-line client nil) (when *please-quit* (return))) while line do (cond ((equal line "freeze") (format t "~&Freezing on client request~%") (loop (sleep 1) (when *please-quit* (return)))) (t (format t "~&Responding to query ~A...~%" line) (format client "(echo ~A)~%" line) (force-output client)))) (close-socket client)))) (close-socket listening-socket))) (defun init-client (&key (unwrap-stream-p t)) (let ((socket (record-socket (trivial-sockets:open-stream "127.0.0.1" *port* :element-type '(unsigned-byte 8)))) (callback nil)) (when (eq unwrap-stream-p :caller) (setf callback (let ((s socket)) (lambda () (close-socket s)))) (setf socket (cl+ssl:stream-fd socket)) (setf unwrap-stream-p nil)) (cl+ssl:make-ssl-client-stream socket :unwrap-stream-p unwrap-stream-p :close-callback callback :external-format :iso-8859-1))) ;; CCL requires specifying the ;; deadline at the socket cration ( ;; in constrast to SBCL which has ;; the WITH-TIMEOUT macro). ;; ;; Therefore a separate INIT-CLIENT ;; function is needed for CCL when ;; we need read/write deadlines on ;; the SSL client stream. #+clozure-common-lisp (defun ccl-init-client-with-deadline (&key (unwrap-stream-p t) seconds) (let* ((deadline (+ (get-internal-real-time) (* seconds internal-time-units-per-second))) (low (record-socket (ccl:make-socket :address-family :internet :connect :active :type :stream :remote-host "127.0.0.1" :remote-port *port* :deadline deadline)))) (cl+ssl:make-ssl-client-stream low :unwrap-stream-p unwrap-stream-p :external-format :iso-8859-1))) ;;; Simple echo-server test. Write a line and check that the result ;;; watches, three times in a row. (deftest echo (with-thread ("simple server" #'init-server #'test-server) (with-open-stream (socket (init-client)) (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)")) (write-line "test2" socket) (force-output socket) (assert (equal (read-line socket) "(echo test2)")) (write-line "test3" socket) (force-output socket) (assert (equal (read-line socket) "(echo test3)"))))) ;;; Run tests with different BIO setup strategies: ;;; - :UNWRAP-STREAMS T ;;; In this case, CL+SSL will convert the socket to a file descriptor. ;;; - :UNWRAP-STREAMS :CLIENT ;;; Convert the socket to a file descriptor manually, and give that ;;; to CL+SSL. ;;; - :UNWRAP-STREAMS NIL ;;; Let CL+SSL write to the stream directly, using the Lisp BIO. (macrolet ((deftests (name (var &rest values) &body body) `(progn ,@(loop for value in values collect `(deftest ,(intern (format nil "~A-~A" name value)) (let ((,var ',value)) ,@body)))))) (deftests unwrap-strategy (usp nil t :caller) (with-thread ("echo server for strategy test" (lambda () (init-server :unwrap-stream-p usp)) #'test-server) (with-open-stream (socket (init-client :unwrap-stream-p usp)) (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)"))))) #+clozure-common-lisp (deftests read-deadline (usp nil t :caller) (with-thread ("echo server for deadline test" (lambda () (init-server :unwrap-stream-p usp)) #'test-server) (with-open-stream (socket (ccl-init-client-with-deadline :unwrap-stream-p usp :seconds 3)) (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)")) (handler-case (progn (read-char socket) (error "unexpected data")) (ccl::communication-deadline-expired ()))))) #+sbcl (deftests read-deadline (usp nil t :caller) (with-thread ("echo server for deadline test" (lambda () (init-server :unwrap-stream-p usp)) #'test-server) (sb-sys:with-deadline (:seconds 3) (with-open-stream (socket (init-client :unwrap-stream-p usp)) (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)")) (handler-case (progn (read-char socket) (error "unexpected data")) (sb-sys:deadline-timeout ())))))) #+clozure-common-lisp (deftests write-deadline (usp nil t) (with-thread ("echo server for deadline test" (lambda () (init-server :unwrap-stream-p usp)) #'test-server) (with-open-stream (socket (ccl-init-client-with-deadline :unwrap-stream-p usp :seconds 3)) (unwind-protect (progn (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)")) (write-line "freeze" socket) (force-output socket) (let ((n 0)) (handler-case (loop (write-line "deadbeef" socket) (incf n)) (ccl::communication-deadline-expired ())) ;; should have written a couple of lines before the deadline: (assert (> n 100)))) (handler-case (close-socket socket :abort t) (ccl::communication-deadline-expired ())))))) #+sbcl (deftests write-deadline (usp nil t) (with-thread ("echo server for deadline test" (lambda () (init-server :unwrap-stream-p usp)) #'test-server) (with-open-stream (socket (init-client :unwrap-stream-p usp)) (unwind-protect (sb-sys:with-deadline (:seconds 3) (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)")) (write-line "freeze" socket) (force-output socket) (let ((n 0)) (handler-case (loop (write-line "deadbeef" socket) (incf n)) (sb-sys:deadline-timeout ())) ;; should have written a couple of lines before the deadline: (assert (> n 100)))) (handler-case (close-socket socket :abort t) (sb-sys:deadline-timeout ())))))) #+clozure-common-lisp (deftests read-char-no-hang/test (usp nil t :caller) (with-thread ("echo server for read-char-no-hang test" (lambda () (init-server :unwrap-stream-p usp)) #'test-server) (with-open-stream (socket (ccl-init-client-with-deadline :unwrap-stream-p usp :seconds 3)) (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)")) (handler-case (when (read-char-no-hang socket) (error "unexpected data")) (ccl::communication-deadline-expired () (error "read-char-no-hang hangs")))))) #+sbcl (deftests read-char-no-hang/test (usp nil t :caller) (with-thread ("echo server for read-char-no-hang test" (lambda () (init-server :unwrap-stream-p usp)) #'test-server) (sb-sys:with-deadline (:seconds 3) (with-open-stream (socket (init-client :unwrap-stream-p usp)) (write-line "test" socket) (force-output socket) (assert (equal (read-line socket) "(echo test)")) (handler-case (when (read-char-no-hang socket) (error "unexpected data")) (sb-sys:deadline-timeout () (error "read-char-no-hang hangs")))))))) #+(or) (run-all-tests) cl+ssl-20170630-git/test/000077500000000000000000000000001311543060700147115ustar00rootroot00000000000000cl+ssl-20170630-git/test/dummy.lisp000066400000000000000000000003611311543060700167350ustar00rootroot00000000000000(in-package :cl+ssl.test) (in-suite :cl+ssl) (test (sanity-check.1 :compile-at :definition-time) (is-true t "SANITY CHECK: T isn't T")) (test (sanity-check.2 :compile-at :definition-time) (is-false nil "SANITY CHECK: NIL isn't NIL")) cl+ssl-20170630-git/test/package.lisp000066400000000000000000000002761311543060700172020ustar00rootroot00000000000000(in-package :cl-user) (defpackage :cl+ssl.test (:use :cl :alexandria :5am)) (in-package :cl+ssl.test) (def-suite :cl+ssl :description "Main test suite for CL+SSL") cl+ssl-20170630-git/test/sni.lisp000066400000000000000000000032521311543060700163750ustar00rootroot00000000000000(in-package :cl+ssl.test) (def-suite :cl+ssl.sni :in :cl+ssl :description "Server Name Indications tests") (in-suite :cl+ssl.sni) (defun make-request-to-sni-test-server (sni-enabled) (usocket:with-client-socket (socket stream "sni.velox.ch" 443 :element-type '(unsigned-byte 8)) (let* ((ssl-stream (cl+ssl:make-ssl-client-stream stream :hostname (if sni-enabled "sni.velox.ch"))) (char-stream (flexi-streams:make-flexi-stream ssl-stream :external-format '(:utf-8 :eol-style :crlf))) (reply-buf (make-string 1000))) (unwind-protect (progn (format char-stream "GET / HTTP/1.1~%") (format char-stream "Host: sni.velox.ch~%~%") (finish-output char-stream) (read-sequence reply-buf char-stream) reply-buf) (close ssl-stream))))) (defun sni-test-request-succeeded-p (response) (search "Great!" response)) (defun sni-test-request-failed-p (response) (search "Unfortunately" response)) ;; Disable the SNI tests because sni.velox.ch was shut down and we ;; haven't found a replacement. ;; ;; (test (sni.disabled :compile-at :definition-time) ;; (is-true (sni-test-request-failed-p (make-request-to-sni-test-server nil)) ;; "Request to SNI test server should've failed because SNI was disabled")) ;; ;; (test (sni.enabled :compile-at :definition-time) ;; (is-true (sni-test-request-succeeded-p (make-request-to-sni-test-server t)) ;; "Request to SNI test server should've succeseeded because SNI was enabled")) cl+ssl-20170630-git/todo.txt000066400000000000000000000036651311543060700154520ustar00rootroot00000000000000- Fix the CCL crash. - Separate project page and a Git repo for trivial-gray-streams. - Remove the ENSURE-INITIALIZED function from the public API. It was only intoroduced to provide users access to the RAND-SEEND which we decided to pass as a parameter to the ENSURE-INITIALIZED. We did this because solaris users complained, as Solaris doesn't have /dev/random, /dev/urnandom files which OpenSSL uses to initialize it's random number generator. But now we know that on Solaris people can use EGD: The Entropy Gathering Daemon: http://egd.sourceforge.net/, and OpenSSL uses it if it's running on a systems without /dev/random. Therefore we should get rid of the ENSURE-INITIALIZED and just put an excerpt from the OpenSSL docs about what software should be installed on the systems without /dev/random. - The stream-fd function is confusing when it's called with ssl-stream as a parameter; a developer might think this function allows to retrieve a socket file descriptor from an ssl-strem, but this function is implemented only for "native" socket streams provided by the Lisp implementation. Makes sense to implement it for ssl-stream too. - The ssl-error-syscall condition uses (err-get-error) in it's :report function. This is not correct; (err-get-error) should be queried when the error occurs. The result might be stored in a slot of the ssl-error-syscall and printed by the :report function. - Fix LispBIO. - Extract the low-level SSL code into a separate library that supports both OpenSSL and GnuTLS (maybe into two thin FFI libraries). - Implement SSL in IOLib adding an API system that only defines stubs that signal an error, and adding implementation systems using the before mentioned thin FFI wrapper libraries. IOLib doesn't support windows, therefore with this plan we will either need to drop Windows support (at tleast for the IOLib based asynch subset of features), or implement Windows support in IOLib.