Recently Written · git

clic

MIRROR ONLY Gopher client with pretty colours in Common Lisp

git clone https://github.com/equwal/clic

Log | Files | Refs

3rdparties/software/cl+ssl-20200427-git/src/ffi.lisp (37286 bytes)

1 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
2 ;;;
3 ;;; Copyright (C) 2001, 2003  Eric Marsden
4 ;;; Copyright (C) 2005  David Lichteblau
5 ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
6 ;;;
7 ;;; See LICENSE for details.
8 
9 #+xcvb (module (:depends-on ("package" "conditions")))
10 
11 (eval-when (:compile-toplevel)
12   (declaim
13    (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0))))
14 
15 (in-package :cl+ssl)
16 
17 ;;; Some lisps (CMUCL) fail when we try to define
18 ;;; a foreign function which is absent in the loaded
19 ;;; foreign library. CMUCL fails when the compiled .fasl
20 ;;; file is loaded, and the failure can not be
21 ;;; captured even by CL condition handlers, i.e.
22 ;;; wrapping (defcfun "removed-function" ...)
23 ;;; into (ignore-errors ...) doesn't help.
24 ;;;
25 ;;; See https://gitlab.common-lisp.net/cmucl/cmucl/issues/74
26 ;;;
27 ;;; As OpenSSL often changs API (removes / adds functions)
28 ;;; we need to solve this problem for CMUCL.
29 ;;;
30 ;;; We do this on CMUCL by calling functions which exists
31 ;;; not in all OpenSSL versions through a pointer
32 ;;; received with cffi:foreign-symbol-pointer.
33 ;;; So a lisp wrapper function for such foreign function
34 ;;; looks up a pointer to the required foreign function
35 ;;; in a hash table.
36 
37 (defparameter *late-bound-foreign-function-pointers*
38   (make-hash-table :test 'equal))
39 
40 (defmacro defcfun-late-bound (name-and-options &body body)
41   (assert (not (eq (alexandria:lastcar body)
42                    '&rest))
43           (body)
44           "The BODY format is implemented in a limited way
45 comparing to CFFI:DEFCFUN - we don't support the &REST which specifies vararg
46 functions. Feel free to implement the support if you have a use case.")
47   (assert (and (>= (length name-and-options) 2)
48                (stringp (first name-and-options))
49                (symbolp (second name-and-options)))
50           (name-and-options)
51           "Unsupported NAME-AND-OPTIONS format: ~S.
52 \(Of all the NAME-AND-OPTIONS variants allowed by CFFI:DEFCFUN we have only
53 implemented support for (FOREIGN-NAME LISP-NAME ...) where FOREIGN-NAME is a
54 STRING and LISP-NAME is a SYMBOL. Fell free to implement support the remaining
55 variants if you have use cases for them.)"
56           name-and-options)
57 
58   (let ((foreign-name-str (first name-and-options))
59         (lisp-name (second name-and-options))
60         (docstring (when (stringp (car body)) (pop body)))
61         (return-type (first body))
62         (arg-names (mapcar #'first (rest body)))
63         (arg-types (mapcar #'second (rest body)))
64         (library (getf (cddr name-and-options) :library))
65         (convention (getf (cddr name-and-options) :convention))
66         (ptr-var (gensym (string 'ptr))))
67     `(progn
68        (setf (gethash ,foreign-name-str *late-bound-foreign-function-pointers*)
69              (or (cffi:foreign-symbol-pointer ,foreign-name-str
70                                               ,@(when library `(:library ',library)))
71                  'foreign-symbol-not-found))
72        (defun ,lisp-name (,@arg-names)
73          ,@(when docstring (list docstring))
74          (let ((,ptr-var (gethash ,foreign-name-str *late-bound-foreign-function-pointers*)))
75            (when (null ,ptr-var)
76              (error "Unexpacted state, no value in *late-bound-foreign-function-pointers* for ~A"
77                     ,foreign-name-str))
78            (when (eq ,ptr-var 'foreign-symbol-not-found)
79              (error "The current version of OpenSSL libcrypto doesn't provide ~A"
80                     ,foreign-name-str))
81            (cffi:foreign-funcall-pointer ,ptr-var
82                                          ,(when convention (list convention))
83                                          ,@(mapcan #'list arg-types arg-names)
84                                          ,return-type))))))
85 
86 (defmacro defcfun-versioned ((&key since vanished) name-and-options &body body)
87   (if (and (or since vanished)
88            (member :cmucl *features*))
89       `(defcfun-late-bound ,name-and-options ,@body)
90       `(cffi:defcfun ,name-and-options ,@body)))
91 
92 
93 ;;; Code for checking that we got the correct foreign symbols right.
94 ;;; Implemented only for LispWorks for now.
95 (defvar *cl+ssl-ssl-foreign-function-names* nil)
96 (defvar *cl+ssl-crypto-foreign-function-names* nil)
97 
98 #+lispworks
99 (defun check-cl+ssl-symbols ()
100   (dolist (ssl-symbol *cl+ssl-ssl-foreign-function-names*)
101     (when (fli:null-pointer-p (fli:make-pointer :symbol-name ssl-symbol :module 'libssl :errorp nil))
102       (format *error-output* "Symbol ~s undefined~%" ssl-symbol)))
103   (dolist (crypto-symbol *cl+ssl-crypto-foreign-function-names*)
104     (when (fli:null-pointer-p (fli:make-pointer :symbol-name crypto-symbol :module 'libcrypto :errorp nil))
105       (format *error-output* "Symbol ~s undefined~%" crypto-symbol))))
106 
107 (defmacro define-ssl-function-ex ((&key since vanished) name-and-options &body body)
108   `(progn
109      ;; debugging
110      (pushnew  ,(car name-and-options)
111                *cl+ssl-ssl-foreign-function-names*
112                :test 'equal)
113      (defcfun-versioned (:since ,since :vanished ,vanished)
114          ,(append name-and-options '(:library libssl))
115        ,@body)))
116 
117 (defmacro define-ssl-function (name-and-options &body body)
118   `(define-ssl-function-ex () ,name-and-options ,@body))
119 
120 (defmacro define-crypto-function-ex ((&key since vanished) name-and-options &body body)
121   `(progn
122      ;; debugging
123      (pushnew ,(car name-and-options)
124               *cl+ssl-crypto-foreign-function-names*
125               :test 'equal)
126      (defcfun-versioned (:since ,since :vanished ,vanished)
127          ;; On Darwin, LispWorks has boringssl always loaded
128          ;; (https://github.com/cl-plus-ssl/cl-plus-ssl/issues/61),
129          ;; ABCL somehow has libressl loaded
130          ;; (https://github.com/cl-plus-ssl/cl-plus-ssl/pull/89),
131          ;; and when we load openssl and declare ffi functions
132          ;; without explicitly specifying the :library option,
133          ;; some foreign symbols are resolved as boringssl / libressl symbols,
134          ;; others are resolved as openssl functions.
135          ;; This mix results in failures, of course.
136          ;; We fix these two implementations by passing the :library option.
137          ;; Not for other implementations because this may be
138          ;; incompatible with :cl+ssl-foreign-libs-already-loaded
139          ;; but these two implementations just break without
140          ;; that, so it's better to possibly sacrify the
141          ;; :cl+ssl-foreign-libs-already-loaded (we haven't tested)
142          ;; than have them broken completely.
143          ;; TODO: extend the :cl+ssl-foreign-libs-already-loaded
144          ;; mechanism with possibility for user to specify value
145          ;; for the :library option.
146          ,(append name-and-options
147                   #+(and (or abcl lispworks) darwin) '(:library libcrypto))
148        ,@body)))
149 
150 (defmacro define-crypto-function (name-and-options &body body)
151   `(define-crypto-function-ex () ,name-and-options ,@body))
152 
153 
154 ;;; Global state
155 ;;;
156 (defvar *ssl-global-context* nil)
157 (defvar *ssl-global-method* nil)
158 (defvar *bio-lisp-method* nil)
159 
160 (defparameter *blockp* t)
161 (defparameter *partial-read-p* nil)
162 
163 (defun ssl-initialized-p ()
164   (and *ssl-global-context* *ssl-global-method*))
165 
166 
167 ;;; Constants
168 ;;;
169 (defconstant +ssl-filetype-pem+ 1)
170 (defconstant +ssl-filetype-asn1+ 2)
171 (defconstant +ssl-filetype-default+ 3)
172 
173 (defconstant +SSL-CTRL-OPTIONS+ 32)
174 (defconstant +SSL_CTRL_SET_SESS_CACHE_MODE+ 44)
175 (defconstant +SSL_CTRL_MODE+ 33)
176 
177 (defconstant +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 2)
178 
179 (defconstant +RSA_F4+ #x10001)
180 
181 (defconstant +SSL-SESS-CACHE-OFF+ #x0000
182   "No session caching for client or server takes place.")
183 (defconstant +SSL-SESS-CACHE-CLIENT+ #x0001
184   "Client sessions are added to the session cache.
185 As there is no reliable way for the OpenSSL library to know whether a session should be reused
186 or which session to choose (due to the abstract BIO layer the SSL engine does not have details
187 about the connection), the application must select the session to be reused by using the
188 SSL-SET-SESSION function. This option is not activated by default.")
189 (defconstant +SSL-SESS-CACHE-SERVER+ #x0002
190   "Server sessions are added to the session cache.
191 When a client proposes a session to be reused, the server looks for the corresponding session
192 in (first) the internal session cache (unless +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ is set), then
193 (second) in the external cache if available. If the session is found, the server will try to
194 reuse the session. This is the default.")
195 (defconstant +SSL-SESS-CACHE-BOTH+ (logior +SSL-SESS-CACHE-CLIENT+ +SSL-SESS-CACHE-SERVER+)
196   "Enable both +SSL-SESS-CACHE-CLIENT+ and +SSL-SESS-CACHE-SERVER+ at the same time.")
197 (defconstant +SSL-SESS-CACHE-NO-AUTO-CLEAR+ #x0080
198   "Normally the session cache is checked for expired sessions every 255 connections using the
199 SSL-CTX-FLUSH-SESSIONS function. Since this may lead to a delay which cannot be controlled,
200 the automatic flushing may be disabled and SSL-CTX-FLUSH-SESSIONS can be called explicitly
201 by the application.")
202 (defconstant +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ #x0100
203   "By setting this flag, session-resume operations in an SSL/TLS server will not automatically
204 look up sessions in the internal cache, even if sessions are automatically stored there.
205 If external session caching callbacks are in use, this flag guarantees that all lookups are
206 directed to the external cache. As automatic lookup only applies for SSL/TLS servers, the flag
207 has no effect on clients.")
208 (defconstant +SSL-SESS-CACHE-NO-INTERNAL-STORE+ #x0200
209   "Depending on the presence of +SSL-SESS-CACHE-CLIENT+ and/or +SSL-SESS-CACHE-SERVER+, sessions
210 negotiated in an SSL/TLS handshake may be cached for possible reuse. Normally a new session is
211 added to the internal cache as well as any external session caching (callback) that is configured
212 for the SSL-CTX. This flag will prevent sessions being stored in the internal cache (though the
213 application can add them manually using SSL-CTX-ADD-SESSION). Note: in any SSL/TLS servers where
214 external caching is configured, any successful session lookups in the external cache (ie. for
215 session-resume requests) would normally be copied into the local cache before processing continues
216 - this flag prevents these additions to the internal cache as well.")
217 (defconstant +SSL-SESS-CACHE-NO-INTERNAL+ (logior +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ +SSL-SESS-CACHE-NO-INTERNAL-STORE+)
218   "Enable both +SSL-SESS-CACHE-NO-INTERNAL-LOOKUP+ and +SSL-SESS-CACHE-NO-INTERNAL-STORE+ at the same time.")
219 
220 (defconstant +SSL-VERIFY-NONE+ #x00)
221 (defconstant +SSL-VERIFY-PEER+ #x01)
222 (defconstant +SSL-VERIFY-FAIL-IF-NO-PEER-CERT+ #x02)
223 (defconstant +SSL-VERIFY-CLIENT-ONCE+ #x04)
224 
225 (defconstant +SSL-OP-ALL+ #x80000BFF)
226 
227 (defconstant +SSL-OP-NO-SSLv2+   #x01000000)
228 (defconstant +SSL-OP-NO-SSLv3+   #x02000000)
229 (defconstant +SSL-OP-NO-TLSv1+   #x04000000)
230 (defconstant +SSL-OP-NO-TLSv1-2+ #x08000000)
231 (defconstant +SSL-OP-NO-TLSv1-1+ #x10000000)
232 
233 (defvar *tmp-rsa-key-512* nil)
234 (defvar *tmp-rsa-key-1024* nil)
235 (defvar *tmp-rsa-key-2048* nil)
236 
237 ;;; Misc
238 ;;;
239 (defmacro while (cond &body body)
240   `(do () ((not ,cond)) ,@body))
241 
242 
243 ;;; Function definitions
244 ;;;
245 
246 (cffi:defcfun (#-windows "close" #+windows "closesocket" close-socket)
247     :int
248   (socket :int))
249 
250 (declaim (inline ssl-write ssl-read ssl-connect ssl-accept))
251 
252 (cffi:defctype ssl-method :pointer)
253 (cffi:defctype ssl-ctx :pointer)
254 (cffi:defctype ssl-pointer :pointer)
255 
256 
257 (define-crypto-function-ex (:vanished "1.1.0") ("SSLeay" ssl-eay)
258         :long)
259 
260 (define-crypto-function-ex (:since "1.1.0") ("OpenSSL_version_num" openssl-version-num)
261         :long)
262 
263 (defun compat-openssl-version ()
264   (or (ignore-errors (openssl-version-num))
265       (ignore-errors (ssl-eay))
266       (error "No OpenSSL version number could be determined, both SSLeay and OpenSSL_version_num failed.")))
267 
268 (defun encode-openssl-version (major minor &optional (patch 0) (prerelease))
269   "Builds a version number to compare OpenSSL against.
270 Note: the _really_ old formats (<= 0.9.4) are not supported."
271   (declare (type (integer 0 3) major)
272            (type (integer 0 10) minor)
273            (type (integer 0 20) patch))
274   (logior (ash major 28)
275           (ash minor 20)
276           (ash patch 4)
277           (if prerelease #xf #x0)))
278 
279 (defun openssl-is-at-least (major minor &optional (patch 0) (prerelease))
280   (>= (compat-openssl-version)
281       (encode-openssl-version major minor patch prerelease)))
282 
283 (defun openssl-is-not-even (major minor &optional (patch 0) (prerelease))
284   (< (compat-openssl-version)
285      (encode-openssl-version major minor patch prerelease)))
286 
287 (defun libresslp ()
288   ;; LibreSSL can be distinguished by
289   ;; OpenSSL_version_num() always returning 0x020000000,
290   ;; where 2 is the major version number.
291   ;; http://man.openbsd.org/OPENSSL_VERSION_NUMBER.3
292   ;; And OpenSSL will never use the major version 2:
293   ;; "This document outlines the design of OpenSSL 3.0, the next version of OpenSSL after 1.1.1"
294   ;; https://www.openssl.org/docs/OpenSSL300Design.html
295   (= #x20000000 (compat-openssl-version)))
296 
297 (define-ssl-function ("SSL_get_version" ssl-get-version)
298     :string
299   (ssl ssl-pointer))
300 (define-ssl-function-ex (:vanished "1.1.0") ("SSL_load_error_strings" ssl-load-error-strings)
301     :void)
302 (define-ssl-function-ex (:vanished "1.1.0") ("SSL_library_init" ssl-library-init)
303     :int)
304 ;;
305 ;; We don't refer SSLv2_client_method as the default
306 ;; builds of OpenSSL do not have it, due to insecurity
307 ;; of the SSL v2 protocol (see https://www.openssl.org/docs/ssl/SSL_CTX_new.html
308 ;; and https://github.com/cl-plus-ssl/cl-plus-ssl/issues/6)
309 ;;
310 ;; (define-ssl-function ("SSLv2_client_method" ssl-v2-client-method)
311 ;;     ssl-method)
312 (define-ssl-function-ex (:vanished "1.1.0") ("SSLv23_client_method" ssl-v23-client-method)
313     ssl-method)
314 (define-ssl-function-ex (:vanished "1.1.0") ("SSLv23_server_method" ssl-v23-server-method)
315     ssl-method)
316 (define-ssl-function-ex (:vanished "1.1.0") ("SSLv23_method" ssl-v23-method)
317     ssl-method)
318 (define-ssl-function-ex (:vanished "1.1.0") ("SSLv3_client_method" ssl-v3-client-method)
319     ssl-method)
320 (define-ssl-function-ex (:vanished "1.1.0") ("SSLv3_server_method" ssl-v3-server-method)
321     ssl-method)
322 (define-ssl-function-ex (:vanished "1.1.0") ("SSLv3_method" ssl-v3-method)
323     ssl-method)
324 (define-ssl-function ("TLSv1_client_method" ssl-TLSv1-client-method)
325     ssl-method)
326 (define-ssl-function ("TLSv1_server_method" ssl-TLSv1-server-method)
327     ssl-method)
328 (define-ssl-function ("TLSv1_method" ssl-TLSv1-method)
329     ssl-method)
330 (define-ssl-function-ex (:since "1.0.2") ("TLSv1_1_client_method" ssl-TLSv1-1-client-method)
331     ssl-method)
332 (define-ssl-function-ex (:since "1.0.2") ("TLSv1_1_server_method" ssl-TLSv1-1-server-method)
333     ssl-method)
334 (define-ssl-function-ex (:since "1.0.2") ("TLSv1_1_method" ssl-TLSv1-1-method)
335     ssl-method)
336 (define-ssl-function-ex (:since "1.0.2") ("TLSv1_2_client_method" ssl-TLSv1-2-client-method)
337     ssl-method)
338 (define-ssl-function-ex (:since "1.0.2") ("TLSv1_2_server_method" ssl-TLSv1-2-server-method)
339     ssl-method)
340 (define-ssl-function-ex (:since "1.0.2") ("TLSv1_2_method" ssl-TLSv1-2-method)
341     ssl-method)
342 (define-ssl-function-ex (:since "1.1.0") ("TLS_method" tls-method)
343     ssl-method)
344 
345 (define-ssl-function ("SSL_CTX_new" ssl-ctx-new)
346     ssl-ctx
347   (method ssl-method))
348 (define-ssl-function ("SSL_new" ssl-new)
349     ssl-pointer
350   (ctx ssl-ctx))
351 (define-ssl-function ("SSL_get_fd" ssl-get-fd)
352     :int
353   (ssl ssl-pointer))
354 (define-ssl-function ("SSL_set_fd" ssl-set-fd)
355     :int
356   (ssl ssl-pointer)
357   (fd :int))
358 (define-ssl-function ("SSL_set_bio" ssl-set-bio)
359     :void
360   (ssl ssl-pointer)
361   (rbio :pointer)
362   (wbio :pointer))
363 (define-ssl-function ("SSL_get_error" ssl-get-error)
364     :int
365   (ssl ssl-pointer)
366   (ret :int))
367 (define-ssl-function ("SSL_set_connect_state" ssl-set-connect-state)
368     :void
369   (ssl ssl-pointer))
370 (define-ssl-function ("SSL_set_accept_state" ssl-set-accept-state)
371     :void
372   (ssl ssl-pointer))
373 (define-ssl-function ("SSL_connect" ssl-connect)
374     :int
375   (ssl ssl-pointer))
376 (define-ssl-function ("SSL_accept" ssl-accept)
377     :int
378   (ssl ssl-pointer))
379 (define-ssl-function ("SSL_write" ssl-write)
380     :int
381   (ssl ssl-pointer)
382   (buf :pointer)
383   (num :int))
384 (define-ssl-function ("SSL_read" ssl-read)
385     :int
386   (ssl ssl-pointer)
387   (buf :pointer)
388   (num :int))
389 (define-ssl-function ("SSL_shutdown" ssl-shutdown)
390     :void
391   (ssl ssl-pointer))
392 (define-ssl-function ("SSL_free" ssl-free)
393     :void
394   (ssl ssl-pointer))
395 (define-ssl-function ("SSL_CTX_free" ssl-ctx-free)
396     :void
397   (ctx ssl-ctx))
398 (define-crypto-function ("BIO_ctrl" bio-set-fd)
399     :long
400   (bio :pointer)
401   (cmd :int)
402   (larg :long)
403   (parg :pointer))
404 (define-crypto-function ("BIO_new_socket" bio-new-socket)
405     :pointer
406   (fd :int)
407   (close-flag :int))
408 (define-crypto-function ("BIO_new" bio-new)
409     :pointer
410   (method :pointer))
411 
412 (define-crypto-function ("ERR_get_error" err-get-error)
413     :unsigned-long)
414 (define-crypto-function ("ERR_error_string" err-error-string)
415     :string
416   (e :unsigned-long)
417   (buf :pointer))
418 
419 (define-ssl-function ("SSL_set_cipher_list" ssl-set-cipher-list)
420     :int
421   (ssl ssl-pointer)
422   (str :string))
423 (define-ssl-function ("SSL_use_RSAPrivateKey_file" ssl-use-rsa-privatekey-file)
424     :int
425   (ssl ssl-pointer)
426   (str :string)
427   ;; either +ssl-filetype-pem+ or +ssl-filetype-asn1+
428   (type :int))
429 (define-ssl-function
430     ("SSL_CTX_use_RSAPrivateKey_file" ssl-ctx-use-rsa-privatekey-file)
431     :int
432   (ctx ssl-ctx)
433   (type :int))
434 (define-ssl-function ("SSL_use_PrivateKey_file" ssl-use-privatekey-file)
435   :int
436   (ssl ssl-pointer)
437   (str :string)
438   ;; either +ssl-filetype-pem+ or +ssl-filetype-asn1+
439   (type :int))
440 (define-ssl-function
441     ("SSL_CTX_use_PrivateKey_file" ssl-ctx-use-privatekey-file)
442   :int
443   (ctx ssl-ctx)
444   (type :int))
445 (define-ssl-function ("SSL_use_certificate_file" ssl-use-certificate-file)
446     :int
447   (ssl ssl-pointer)
448   (str :string)
449   (type :int))
450 #+new-openssl
451 (define-ssl-function ("SSL_CTX_set_options" ssl-ctx-set-options)
452                  :long
453                (ctx :pointer)
454                (options :long))
455 #-new-openssl
456 (defun ssl-ctx-set-options (ctx options)
457   (ssl-ctx-ctrl ctx +SSL-CTRL-OPTIONS+ options (cffi:null-pointer)))
458 (define-ssl-function ("SSL_CTX_set_cipher_list" ssl-ctx-set-cipher-list%)
459     :int
460   (ctx :pointer)
461   (ciphers :pointer))
462 (defun ssl-ctx-set-cipher-list (ctx ciphers)
463   (cffi:with-foreign-string (ciphers* ciphers)
464     (when (= 0 (ssl-ctx-set-cipher-list% ctx ciphers*))
465       (error 'ssl-error-initialize :reason "Can't set SSL cipher list" :queue (read-ssl-error-queue)))))
466 (define-ssl-function ("SSL_CTX_use_certificate_chain_file" ssl-ctx-use-certificate-chain-file)
467     :int
468   (ctx ssl-ctx)
469   (str :string))
470 (define-ssl-function ("SSL_CTX_load_verify_locations" ssl-ctx-load-verify-locations)
471     :int
472   (ctx ssl-ctx)
473   (CAfile :string)
474   (CApath :string))
475 (define-ssl-function ("SSL_CTX_set_client_CA_list" ssl-ctx-set-client-ca-list)
476     :void
477   (ctx ssl-ctx)
478   (list ssl-pointer))
479 (define-ssl-function ("SSL_load_client_CA_file" ssl-load-client-ca-file)
480     ssl-pointer
481   (file :string))
482 
483 (define-ssl-function ("SSL_CTX_ctrl" ssl-ctx-ctrl)
484     :long
485   (ctx ssl-ctx)
486   (cmd :int)
487   ;; Despite declared as long in the original OpenSSL headers,
488   ;; passing to larg for example 2181041151 which is the result of
489   ;;     (logior cl+ssl::+SSL-OP-ALL+
490   ;;             cl+ssl::+SSL-OP-NO-SSLv2+
491   ;;             cl+ssl::+SSL-OP-NO-SSLv3+)
492   ;; causes CFFI on 32 bit platforms to signal an error
493   ;; "The value 2181041151 is not of the expected type (SIGNED-BYTE 32)"
494   ;; The problem is that 2181041151 requires 32 bits by itself and
495   ;; there is no place left for the sign bit.
496   ;; In C the compiler silently coerces unsigned to signed,
497   ;; but CFFI raises this error.
498   ;; Therefore we use :UNSIGNED-LONG for LARG.
499   (larg :unsigned-long)
500   (parg :pointer))
501 
502 (define-ssl-function ("SSL_ctrl" ssl-ctrl)
503     :long
504   (ssl :pointer)
505   (cmd :int)
506   (larg :long)
507   (parg :pointer))
508 
509 (define-ssl-function ("SSL_CTX_set_default_passwd_cb" ssl-ctx-set-default-passwd-cb)
510     :void
511   (ctx ssl-ctx)
512   (pem_passwd_cb :pointer))
513 
514 (define-crypto-function-ex (:vanished "1.1.0") ("CRYPTO_num_locks" crypto-num-locks) :int)
515 (define-crypto-function-ex (:vanished "1.1.0") ("CRYPTO_set_locking_callback" crypto-set-locking-callback)
516     :void
517   (fun :pointer))
518 (define-crypto-function-ex (:vanished "1.1.0") ("CRYPTO_set_id_callback" crypto-set-id-callback)
519     :void
520   (fun :pointer))
521 
522 (define-crypto-function ("RAND_seed" rand-seed)
523     :void
524   (buf :pointer)
525   (num :int))
526 (define-crypto-function ("RAND_bytes" rand-bytes)
527     :int
528   (buf :pointer)
529   (num :int))
530 
531 (define-ssl-function ("SSL_CTX_set_verify_depth" ssl-ctx-set-verify-depth)
532     :void
533   (ctx :pointer)
534   (depth :int))
535 
536 (define-ssl-function ("SSL_CTX_set_verify" ssl-ctx-set-verify)
537     :void
538   (ctx :pointer)
539   (mode :int)
540   (verify-callback :pointer))
541 
542 (define-ssl-function ("SSL_get_verify_result" ssl-get-verify-result)
543     :long
544   (ssl ssl-pointer))
545 
546 (define-ssl-function ("SSL_get_peer_certificate" ssl-get-peer-certificate)
547     :pointer
548   (ssl ssl-pointer))
549 
550 ;;; X509 & ASN1
551 (define-crypto-function ("X509_free" x509-free)
552     :void
553   (x509 :pointer))
554 
555 (define-crypto-function ("X509_NAME_oneline" x509-name-oneline)
556     :pointer
557   (x509-name :pointer)
558   (buf :pointer)
559   (size :int))
560 
561 (define-crypto-function ("X509_NAME_get_index_by_NID" x509-name-get-index-by-nid)
562     :int
563   (name :pointer)
564   (nid :int)
565   (lastpos :int))
566 
567 (define-crypto-function ("X509_NAME_get_entry" x509-name-get-entry)
568     :pointer
569   (name :pointer)
570   (log :int))
571 
572 (define-crypto-function ("X509_NAME_ENTRY_get_data" x509-name-entry-get-data)
573     :pointer
574   (name-entry :pointer))
575 
576 (define-crypto-function ("X509_get_issuer_name" x509-get-issuer-name)
577     :pointer                            ; *X509_NAME
578   (x509 :pointer))
579 
580 (define-crypto-function ("X509_get_subject_name" x509-get-subject-name)
581     :pointer                            ; *X509_NAME
582   (x509 :pointer))
583 
584 (define-crypto-function ("X509_get_ext_d2i" x509-get-ext-d2i)
585     :pointer
586   (cert :pointer)
587   (nid :int)
588   (crit :pointer)
589   (idx :pointer))
590 
591 (define-crypto-function ("X509_STORE_CTX_get_error" x509-store-ctx-get-error)
592     :int
593   (ctx :pointer))
594 
595 (define-crypto-function ("d2i_X509" d2i-x509)
596     :pointer
597   (*px :pointer)
598   (in :pointer)
599   (len :int))
600 
601 ;; GENERAL-NAME types
602 (defconstant +GEN-OTHERNAME+  0)
603 (defconstant +GEN-EMAIL+  1)
604 (defconstant +GEN-DNS+    2)
605 (defconstant +GEN-X400+ 3)
606 (defconstant +GEN-DIRNAME+  4)
607 (defconstant +GEN-EDIPARTY+ 5)
608 (defconstant +GEN-URI+    6)
609 (defconstant +GEN-IPADD+  7)
610 (defconstant +GEN-RID+    8)
611 
612 (defconstant +v-asn1-octet-string+ 4)
613 (defconstant +v-asn1-utf8string+ 12)
614 (defconstant +v-asn1-printablestring+ 19)
615 (defconstant +v-asn1-teletexstring+ 20)
616 (defconstant +v-asn1-iastring+ 22)
617 (defconstant +v-asn1-universalstring+ 28)
618 (defconstant +v-asn1-bmpstring+ 30)
619 
620 
621 (defconstant +NID-subject-alt-name+ 85)
622 (defconstant +NID-commonName+   13)
623 
624 (cffi:defcstruct general-name
625   (type :int)
626   (data :pointer))
627 
628 (define-crypto-function-ex (:vanished "1.1.0") ("sk_value" sk-value)
629     :pointer
630   (stack :pointer)
631   (index :int))
632 
633 (define-crypto-function-ex (:vanished "1.1.0") ("sk_num" sk-num)
634     :int
635   (stack :pointer))
636 
637 (define-crypto-function-ex (:since "1.1.0") ("OPENSSL_sk_value" openssl-sk-value)
638     :pointer
639   (stack :pointer)
640   (index :int))
641 
642 (define-crypto-function-ex (:since "1.1.0") ("OPENSSL_sk_num" openssl-sk-num)
643     :int
644   (stack :pointer))
645 
646 (declaim (ftype (function (cffi:foreign-pointer fixnum) cffi:foreign-pointer) sk-general-name-value))
647 (defun sk-general-name-value (names index)
648   (if (and (not (libresslp))
649            (openssl-is-at-least 1 1))
650       (openssl-sk-value names index)
651       (sk-value names index)))
652 
653 (declaim (ftype (function (cffi:foreign-pointer) fixnum) sk-general-name-num))
654 (defun sk-general-name-num (names)
655   (if (and (not (libresslp))
656            (openssl-is-at-least 1 1))
657       (openssl-sk-num names)
658       (sk-num names)))
659 
660 (define-crypto-function ("GENERAL_NAMES_free" general-names-free)
661     :void
662   (general-names :pointer))
663 
664 (define-crypto-function ("ASN1_STRING_data" asn1-string-data)
665     :pointer
666   (asn1-string :pointer))
667 
668 (define-crypto-function ("ASN1_STRING_length" asn1-string-length)
669     :int
670   (asn1-string :pointer))
671 
672 (define-crypto-function ("ASN1_STRING_type" asn1-string-type)
673     :int
674   (asn1-string :pointer))
675 
676 (cffi:defcstruct asn1_string_st
677   (length :int)
678   (type :int)
679   (data :pointer)
680   (flags :long))
681 
682 ;; X509 & ASN1 - end
683 
684 (define-ssl-function ("SSL_CTX_set_default_verify_paths" ssl-ctx-set-default-verify-paths)
685     :int
686   (ctx :pointer))
687 
688 (define-ssl-function-ex (:since "1.1.0") ("SSL_CTX_set_default_verify_dir" ssl-ctx-set-default-verify-dir)
689     :int
690   (ctx :pointer))
691 
692 (define-ssl-function-ex (:since "1.1.0") ("SSL_CTX_set_default_verify_file" ssl-ctx-set-default-verify-file)
693     :int
694   (ctx :pointer))
695 
696 (define-crypto-function ("RSA_generate_key" rsa-generate-key)
697     :pointer
698   (num :int)
699   (e :unsigned-long)
700   (callback :pointer)
701   (opt :pointer))
702 
703 (define-crypto-function ("RSA_free" rsa-free)
704     :void
705   (rsa :pointer))
706 
707 (define-ssl-function-ex (:vanished "1.1.0") ("SSL_CTX_set_tmp_rsa_callback" ssl-ctx-set-tmp-rsa-callback)
708     :pointer
709   (ctx :pointer)
710   (callback :pointer))
711 
712 (cffi:defcallback tmp-rsa-callback :pointer ((ssl :pointer) (export-p :int) (key-length :int))
713   (declare (ignore ssl export-p))
714   (flet ((rsa-key (length)
715            (rsa-generate-key length
716                              +RSA_F4+
717                              (cffi:null-pointer)
718                              (cffi:null-pointer))))
719     (cond ((= key-length 512)
720            (unless *tmp-rsa-key-512*
721              (setf *tmp-rsa-key-512* (rsa-key key-length)))
722            *tmp-rsa-key-512*)
723           ((= key-length 1024)
724            (unless *tmp-rsa-key-1024*
725              (setf *tmp-rsa-key-1024* (rsa-key key-length)))
726            *tmp-rsa-key-1024*)
727           (t
728            (unless *tmp-rsa-key-2048*
729              (setf *tmp-rsa-key-2048* (rsa-key key-length)))
730            *tmp-rsa-key-2048*))))
731 
732 ;;; Funcall wrapper
733 ;;;
734 (defvar *socket*)
735 
736 (declaim (inline ensure-ssl-funcall))
737 (defun ensure-ssl-funcall (stream handle func &rest args)
738   (loop
739      (let ((nbytes
740       (let ((*socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks
741         (apply func args))))
742        (when (plusp nbytes)
743    (return nbytes))
744        (let ((error (ssl-get-error handle nbytes)))
745    (case error
746      (#.+ssl-error-want-read+
747       (input-wait stream
748       (ssl-get-fd handle)
749       (ssl-stream-deadline stream)))
750      (#.+ssl-error-want-write+
751       (output-wait stream
752        (ssl-get-fd handle)
753        (ssl-stream-deadline stream)))
754      (t
755       (ssl-signal-error handle func error nbytes)))))))
756 
757 (declaim (inline nonblocking-ssl-funcall))
758 (defun nonblocking-ssl-funcall (stream handle func &rest args)
759   (loop
760      (let ((nbytes
761       (let ((*socket* (ssl-stream-socket stream))) ;for Lisp-BIO callbacks
762         (apply func args))))
763        (when (plusp nbytes)
764    (return nbytes))
765        (let ((error (ssl-get-error handle nbytes)))
766    (case error
767      ((#.+ssl-error-want-read+ #.+ssl-error-want-write+)
768       (return nbytes))
769      (t
770       (ssl-signal-error handle func error nbytes)))))))
771 
772 
773 ;;; Waiting for output to be possible
774 
775 #+clozure-common-lisp
776 (defun milliseconds-until-deadline (deadline stream)
777   (let* ((now (get-internal-real-time)))
778     (if (> now deadline)
779   (error 'ccl::communication-deadline-expired :stream stream)
780   (values
781    (round (- deadline now) (/ internal-time-units-per-second 1000))))))
782 
783 #+clozure-common-lisp
784 (defun output-wait (stream fd deadline)
785   (unless deadline
786     (setf deadline (stream-deadline (ssl-stream-socket stream))))
787   (let* ((timeout
788     (if deadline
789         (milliseconds-until-deadline deadline stream)
790         nil)))
791     (multiple-value-bind (win timedout error)
792   (ccl::process-output-wait fd timeout)
793       (unless win
794   (if timedout
795       (error 'ccl::communication-deadline-expired :stream stream)
796       (ccl::stream-io-error stream (- error) "write"))))))
797 
798 #+sbcl
799 (defun output-wait (stream fd deadline)
800   (declare (ignore stream))
801   (let ((timeout
802    ;; *deadline* is handled by wait-until-fd-usable automatically,
803    ;; but we need to turn a user-specified deadline into a timeout
804    (when deadline
805      (/ (- deadline (get-internal-real-time))
806         internal-time-units-per-second))))
807     (sb-sys:wait-until-fd-usable fd :output timeout)))
808 
809 #-(or clozure-common-lisp sbcl)
810 (defun output-wait (stream fd deadline)
811   (declare (ignore stream fd deadline))
812   ;; This situation means that the lisp set our fd to non-blocking mode,
813   ;; and streams.lisp didn't know how to undo that.
814   (warn "non-blocking stream encountered unexpectedly"))
815 
816 
817 ;;; Waiting for input to be possible
818 
819 #+clozure-common-lisp
820 (defun input-wait (stream fd deadline)
821   (unless deadline
822     (setf deadline (stream-deadline (ssl-stream-socket stream))))
823   (let* ((timeout
824     (if deadline
825         (milliseconds-until-deadline deadline stream)
826         nil)))
827     (multiple-value-bind (win timedout error)
828   (ccl::process-input-wait fd timeout)
829       (unless win
830   (if timedout
831       (error 'ccl::communication-deadline-expired :stream stream)
832       (ccl::stream-io-error stream (- error) "read"))))))
833 
834 #+sbcl
835 (defun input-wait (stream fd deadline)
836   (declare (ignore stream))
837   (let ((timeout
838    ;; *deadline* is handled by wait-until-fd-usable automatically,
839    ;; but we need to turn a user-specified deadline into a timeout
840    (when deadline
841      (/ (- deadline (get-internal-real-time))
842         internal-time-units-per-second))))
843     (sb-sys:wait-until-fd-usable fd :input timeout)))
844 
845 #-(or clozure-common-lisp sbcl)
846 (defun input-wait (stream fd deadline)
847   (declare (ignore stream fd deadline))
848   ;; This situation means that the lisp set our fd to non-blocking mode,
849   ;; and streams.lisp didn't know how to undo that.
850   (warn "non-blocking stream encountered unexpectedly"))
851 
852 
853 ;;; Encrypted PEM files support
854 ;;;
855 
856 ;; based on http://www.openssl.org/docs/ssl/SSL_CTX_set_default_passwd_cb.html
857 
858 (defvar *pem-password* ""
859   "The callback registered with SSL_CTX_set_default_passwd_cb
860 will use this value.")
861 
862 ;; The callback itself
863 (cffi:defcallback pem-password-callback :int
864     ((buf :pointer) (size :int) (rwflag :int) (unused :pointer))
865   (declare (ignore rwflag unused))
866   (let* ((password-str (coerce *pem-password* 'base-string))
867          (tmp (cffi:foreign-string-alloc password-str)))
868     (cffi:foreign-funcall "strncpy"
869                           :pointer buf
870                           :pointer tmp
871                           :int size)
872     (cffi:foreign-string-free tmp)
873     (setf (cffi:mem-ref buf :char (1- size)) 0)
874     (cffi:foreign-funcall "strlen" :pointer buf :int)))
875 
876 ;; The macro to be used by other code to provide password
877 ;; when loading PEM file.
878 (defmacro with-pem-password ((password) &body body)
879   `(let ((*pem-password* (or ,password "")))
880          ,@body))
881 
882 
883 ;;; Initialization
884 ;;;
885 
886 (defun init-prng (seed-byte-sequence)
887   (let* ((length (length seed-byte-sequence))
888          (buf (cffi:make-shareable-byte-vector length)))
889     (dotimes (i length)
890       (setf (elt buf i) (elt seed-byte-sequence i)))
891     (cffi:with-pointer-to-vector-data (ptr buf)
892       (rand-seed ptr length))))
893 
894 (defun ssl-ctx-set-session-cache-mode (ctx mode)
895   (ssl-ctx-ctrl ctx +SSL_CTRL_SET_SESS_CACHE_MODE+ mode (cffi:null-pointer)))
896 
897 (defun ssl-set-tlsext-host-name (ctx hostname)
898   (ssl-ctrl ctx 55 #|SSL_CTRL_SET_TLSEXT_HOSTNAME|# 0 #|TLSEXT_NAMETYPE_host_name|# hostname))
899 
900 (defvar *locks*)
901 (defconstant +CRYPTO-LOCK+ 1)
902 (defconstant +CRYPTO-UNLOCK+ 2)
903 (defconstant +CRYPTO-READ+ 4)
904 (defconstant +CRYPTO-WRITE+ 8)
905 
906 ;; zzz as of early 2011, bxthreads is totally broken on SBCL wrt. explicit
907 ;; locking of recursive locks.  with-recursive-lock works, but acquire/release
908 ;; don't.  Hence we use non-recursize locks here (but can use a recursive
909 ;; lock for the global lock).
910 
911 (cffi:defcallback locking-callback :void
912     ((mode :int)
913      (n :int)
914      (file :pointer) ;; could be (file :string), but we don't use FILE, so avoid the conversion
915      (line :int))
916   (declare (ignore file line))
917   ;; (assert (logtest mode (logior +CRYPTO-READ+ +CRYPTO-WRITE+)))
918   (let ((lock (elt *locks* n)))
919     (cond
920       ((logtest mode +CRYPTO-LOCK+)
921        (bt:acquire-lock lock))
922       ((logtest mode +CRYPTO-UNLOCK+)
923        (bt:release-lock lock))
924       (t
925        (error "fell through")))))
926 
927 (defvar *threads* (trivial-garbage:make-weak-hash-table :weakness :key))
928 (defvar *thread-counter* 0)
929 
930 (defparameter *global-lock*
931   (bordeaux-threads:make-recursive-lock "SSL initialization"))
932 
933 ;; zzz BUG: On a 32-bit system and under non-trivial load, this counter
934 ;; is likely to wrap in less than a year.
935 (cffi:defcallback threadid-callback :unsigned-long ()
936   (bordeaux-threads:with-recursive-lock-held (*global-lock*)
937     (let ((self (bt:current-thread)))
938       (or (gethash self *threads*)
939     (setf (gethash self *threads*)
940     (incf *thread-counter*))))))
941 
942 (defvar *ssl-check-verify-p* :unspecified
943   "DEPRECATED.
944 Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification.
945 MAKE-CONTEXT also allows to enab/disable verification.")
946 
947 (defun default-ssl-method ()
948   (if (openssl-is-at-least 1 1)
949       'tls-method
950       'ssl-v23-method))
951 
952 (defun initialize (&key method rand-seed)
953   (when (or (openssl-is-not-even 1 1)
954             ;; Old versions of LibreSSL
955             ;; require this initialization
956             ;; (https://github.com/cl-plus-ssl/cl-plus-ssl/pull/91),
957             ;; new versions keep this API backwards
958             ;; compatible so we can call it too.
959             (libresslp))
960     (setf *locks* (loop
961                      repeat (crypto-num-locks)
962                      collect (bt:make-lock)))
963     (crypto-set-locking-callback (cffi:callback locking-callback))
964     (crypto-set-id-callback (cffi:callback threadid-callback))
965     (ssl-load-error-strings)
966     (ssl-library-init))
967   (setf *bio-lisp-method* (make-bio-lisp-method))
968   (when rand-seed
969     (init-prng rand-seed))
970   (setf *ssl-check-verify-p* :unspecified)
971   (setf *ssl-global-method* (funcall (or method (default-ssl-method))))
972   (setf *ssl-global-context* (ssl-ctx-new *ssl-global-method*))
973   (unless (eql 1 (ssl-ctx-set-default-verify-paths *ssl-global-context*))
974     (error "ssl-ctx-set-default-verify-paths failed."))
975   (ssl-ctx-set-session-cache-mode *ssl-global-context* 3)
976   (ssl-ctx-set-default-passwd-cb *ssl-global-context*
977                                  (cffi:callback pem-password-callback))
978   (when (or (openssl-is-not-even 1 1)
979             ;; Again, even if newer LibreSSL
980             ;; don't need this call, they keep
981             ;; the API compatibility so we can continue
982             ;; making this call.
983             (libresslp))
984     (ssl-ctx-set-tmp-rsa-callback *ssl-global-context*
985                                   (cffi:callback tmp-rsa-callback))))
986 
987 (defun ensure-initialized (&key method (rand-seed nil))
988   "In most cases you do *not* need to call this function, because it
989 is called automatically by all other functions. The only reason to
990 call it explicitly is to supply the RAND-SEED parameter. In this case
991 do it before calling any other functions.
992 
993 Just leave the default value for the METHOD parameter.
994 
995 RAND-SEED is an octet sequence to initialize OpenSSL random number generator.
996 On many platforms, including Linux and Windows, it may be leaved NIL (default),
997 because OpenSSL initializes the random number generator from OS specific service.
998 But for example on Solaris it may be necessary to supply this value.
999 The minimum length required by OpenSSL is 128 bits.
1000 See ttp://www.openssl.org/support/faq.html#USER1 for details.
1001 
1002 Hint: do not use Common Lisp RANDOM function to generate the RAND-SEED,
1003 because the function usually returns predictable values."
1004   #+lispworks
1005   (check-cl+ssl-symbols)
1006   (bordeaux-threads:with-recursive-lock-held (*global-lock*)
1007     (unless (ssl-initialized-p)
1008       (initialize :method method :rand-seed rand-seed))
1009     (unless *bio-lisp-method*
1010       (setf *bio-lisp-method* (make-bio-lisp-method)))))
1011 
1012 (defun use-certificate-chain-file (certificate-chain-file)
1013   "Loads a PEM encoded certificate chain file CERTIFICATE-CHAIN-FILE
1014 and adds the chain to global context. The certificates must be sorted
1015 starting with the subject's certificate (actual client or server certificate),
1016 followed by intermediate CA certificates if applicable, and ending at
1017 the highest level (root) CA. Note: the RELOAD function clears the global
1018 context and in particular the loaded certificate chain."
1019   (ensure-initialized)
1020   (ssl-ctx-use-certificate-chain-file *ssl-global-context* certificate-chain-file))
1021 
1022 (defun reload ()
1023   (if *ssl-global-context*
1024       (ssl-ctx-free *ssl-global-context*))
1025   (unless (member :cl+ssl-foreign-libs-already-loaded
1026                   *features*)
1027     (cffi:use-foreign-library libcrypto)
1028     (cffi:load-foreign-library 'libssl))
1029   (setf *ssl-global-context* nil)
1030   (setf *ssl-global-method* nil)
1031   (setf *tmp-rsa-key-512* nil)
1032   (setf *tmp-rsa-key-1024* nil))