Coverage report: /home/ellis/.stash/lisp/cl-plus-ssl/src/init.lisp

KindCoveredAll%
expression51194 26.3
branch622 27.3
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
2
 ;;;
3
 ;;; Copyright (C) contributors as per cl+ssl git history
4
 ;;;
5
 ;;; See LICENSE for details.
6
 
7
 (eval-when (:compile-toplevel)
8
   (declaim
9
    (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0))))
10
 
11
 (in-package :cl+ssl)
12
 
13
 ;;; Global state
14
 ;;;
15
 (defvar *ssl-global-context* nil)
16
 (defvar *ssl-global-method* nil)
17
 
18
 (defun ssl-initialized-p ()
19
   (and *ssl-global-context* *ssl-global-method*))
20
 
21
 (defvar *tmp-rsa-key-512* nil)
22
 (defvar *tmp-rsa-key-1024* nil)
23
 (defvar *tmp-rsa-key-2048* nil)
24
 
25
 (cffi:defcallback tmp-rsa-callback :pointer ((ssl :pointer) (export-p :int) (key-length :int))
26
   (declare (ignore ssl export-p))
27
   (flet ((rsa-key (length)
28
            (rsa-generate-key length
29
                              +RSA_F4+
30
                              (cffi:null-pointer)
31
                              (cffi:null-pointer))))
32
     (cond ((= key-length 512)
33
            (unless *tmp-rsa-key-512*
34
              (setf *tmp-rsa-key-512* (rsa-key key-length)))
35
            *tmp-rsa-key-512*)
36
           ((= key-length 1024)
37
            (unless *tmp-rsa-key-1024*
38
              (setf *tmp-rsa-key-1024* (rsa-key key-length)))
39
            *tmp-rsa-key-1024*)
40
           (t
41
            (unless *tmp-rsa-key-2048*
42
              (setf *tmp-rsa-key-2048* (rsa-key key-length)))
43
            *tmp-rsa-key-2048*))))
44
 
45
 
46
 ;;; Encrypted PEM files support
47
 ;;;
48
 
49
 ;; based on http://www.openssl.org/docs/ssl/SSL_CTX_set_default_passwd_cb.html
50
 
51
 (defvar *pem-password* ""
52
   "The callback registered with SSL_CTX_set_default_passwd_cb
53
 will use this value.")
54
 
55
 ;; The callback itself
56
 (cffi:defcallback pem-password-callback :int
57
     ((buf :pointer) (size :int) (rwflag :int) (unused :pointer))
58
   (declare (ignore rwflag unused))
59
   (let* ((password-str (coerce *pem-password* 'base-string))
60
          (tmp (cffi:foreign-string-alloc password-str)))
61
     (cffi:foreign-funcall "strncpy"
62
                           :pointer buf
63
                           :pointer tmp
64
                           :int size)
65
     (cffi:foreign-string-free tmp)
66
     (setf (cffi:mem-ref buf :char (1- size)) 0)
67
     (cffi:foreign-funcall "strlen" :pointer buf :int)))
68
 
69
 ;; The macro to be used by other code to provide password
70
 ;; when loading PEM file.
71
 (defmacro with-pem-password ((password) &body body)
72
   `(let ((*pem-password* (or ,password "")))
73
      ,@body))
74
 
75
 
76
 ;;; Initialization
77
 ;;;
78
 
79
 (defun init-prng (seed-byte-sequence)
80
   (let* ((length (length seed-byte-sequence))
81
          (buf (cffi:make-shareable-byte-vector length)))
82
     (dotimes (i length)
83
       (setf (elt buf i) (elt seed-byte-sequence i)))
84
     (cffi:with-pointer-to-vector-data (ptr buf)
85
       (rand-seed ptr length))))
86
 
87
 (defvar *locks*)
88
 
89
 ;; zzz as of early 2011, bxthreads is totally broken on SBCL wrt. explicit
90
 ;; locking of recursive locks.  with-recursive-lock works, but acquire/release
91
 ;; don't.  Hence we use non-recursize locks here (but can use a recursive
92
 ;; lock for the global lock).
93
 
94
 (cffi:defcallback locking-callback :void
95
     ((mode :int)
96
      (n :int)
97
      (file :pointer) ;; could be (file :string), but we don't use FILE, so avoid the conversion
98
      (line :int))
99
   (declare (ignore file line))
100
   ;; (assert (logtest mode (logior +CRYPTO-READ+ +CRYPTO-WRITE+)))
101
   (let ((lock (elt *locks* n)))
102
     (cond
103
       ((logtest mode +CRYPTO-LOCK+)
104
        (bt:acquire-lock lock))
105
       ((logtest mode +CRYPTO-UNLOCK+)
106
        (bt:release-lock lock))
107
       (t
108
        (error "fell through")))))
109
 
110
 (defvar *threads* (trivial-garbage:make-weak-hash-table :weakness :key))
111
 (defvar *thread-counter* 0)
112
 
113
 (defparameter *global-lock*
114
   (bordeaux-threads:make-recursive-lock "SSL initialization"))
115
 
116
 ;; zzz BUG: On a 32-bit system and under non-trivial load, this counter
117
 ;; is likely to wrap in less than a year.
118
 (cffi:defcallback threadid-callback :unsigned-long ()
119
   (bordeaux-threads:with-recursive-lock-held (*global-lock*)
120
     (let ((self (bt:current-thread)))
121
       (or (gethash self *threads*)
122
           (setf (gethash self *threads*)
123
                 (incf *thread-counter*))))))
124
 
125
 (defvar *ssl-check-verify-p* :unspecified
126
   "DEPRECATED.
127
 Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification.
128
 MAKE-CONTEXT also allows to enab/disable verification.")
129
 
130
 (defun default-ssl-method ()
131
   (if (openssl-is-at-least 1 1)
132
       'tls-method
133
       'ssl-v23-method))
134
 
135
 (defun initialize (&key method rand-seed)
136
   (when (or (openssl-is-not-even 1 1)
137
             ;; Old versions of LibreSSL
138
             ;; require this initialization
139
             ;; (https://github.com/cl-plus-ssl/cl-plus-ssl/pull/91),
140
             ;; new versions keep this API backwards
141
             ;; compatible so we can call it too.
142
             (libresslp))
143
     (setf *locks* (loop
144
                      repeat (crypto-num-locks)
145
                      collect (bt:make-lock)))
146
     (crypto-set-locking-callback (cffi:callback locking-callback))
147
     (crypto-set-id-callback (cffi:callback threadid-callback))
148
     (ssl-load-error-strings)
149
     (ssl-library-init)
150
     ;; However, for OpenSSL_add_all_digests the LibreSSL breaks
151
     ;; the backward compatibility by removing the function.
152
     ;; https://github.com/cl-plus-ssl/cl-plus-ssl/pull/134
153
     (unless (libresslp)
154
       (openssl-add-all-digests)))
155
 
156
   (bio-init)
157
 
158
   (when rand-seed
159
     (init-prng rand-seed))
160
   (setf *ssl-check-verify-p* :unspecified)
161
   (setf *ssl-global-method* (funcall (or method (default-ssl-method))))
162
   (setf *ssl-global-context* (ssl-ctx-new *ssl-global-method*))
163
   (unless (eql 1 (ssl-ctx-set-default-verify-paths *ssl-global-context*))
164
     (error "ssl-ctx-set-default-verify-paths failed."))
165
   (ssl-ctx-set-session-cache-mode *ssl-global-context* 3)
166
   (ssl-ctx-set-default-passwd-cb *ssl-global-context*
167
                                  (cffi:callback pem-password-callback))
168
   (when (or (openssl-is-not-even 1 1)
169
             ;; Again, even if newer LibreSSL
170
             ;; don't need this call, they keep
171
             ;; the API compatibility so we can continue
172
             ;; making this call.
173
             (libresslp))
174
     (ssl-ctx-set-tmp-rsa-callback *ssl-global-context*
175
                                   (cffi:callback tmp-rsa-callback))))
176
 
177
 (defun ensure-initialized (&key method (rand-seed nil))
178
   "In most cases you do *not* need to call this function, because it
179
 is called automatically by all other functions. The only reason to
180
 call it explicitly is to supply the RAND-SEED parameter. In this case
181
 do it before calling any other functions.
182
 
183
 Keyword arguments:
184
 
185
     METHOD - just leave the default value.
186
 
187
     RAND-SEED - an octet sequence to initialize OpenSSL random
188
         number generator. On many platforms, including Linux and
189
         Windows, it may be left NIL (default), because OpenSSL
190
         initializes the random number generator from OS specific
191
         service. But, for example, on Solaris it may be necessary
192
         to supply this value. The minimum length required by OpenSSL
193
         is 128 bits.
194
         See http://www.openssl.org/support/faq.html#USER1 for details.
195
 
196
         Hint: do not use Common Lisp RANDOM function to generate
197
         the RAND-SEED, because the function usually returns
198
         predictable values.
199
 "
200
   #+lispworks
201
   (check-cl+ssl-symbols)
202
   (bordeaux-threads:with-recursive-lock-held (*global-lock*)
203
     (unless (ssl-initialized-p)
204
       (initialize :method method :rand-seed rand-seed))))
205
 
206
 (defun use-certificate-chain-file (certificate-chain-file)
207
   "Applies OpenSSL function SSL_CTX_use_certificate_chain_file
208
 to the cl+ssl's global SSL_CTX object and the specified
209
 CERTIFICATE-CHAIN-FILE.
210
 
211
 OpenSSL requires the certificates in the file to be sorted
212
 starting with the subject's certificate (actual client or
213
 server certificate), followed by intermediate CA certificates
214
 if applicable, and ending at the highest level (root) CA.
215
 
216
 Note: the RELOAD function clears the global context and in particular
217
 the loaded certificate chain."
218
   (ensure-initialized)
219
   (ssl-ctx-use-certificate-chain-file *ssl-global-context* certificate-chain-file))
220
 
221
 (defun reload ()
222
   "If you save your application as a Lisp image,
223
 call this function when that image is loaded,
224
 to perform the necessary CL+SSL re-initialization
225
 (unless your lisp implementation automatically
226
 re-loads foreign libraries and preserves their
227
 memory accross image reloads).
228
 
229
 This should work fine if the location and version of the
230
 OpenSSL shared libraries have not changed.
231
 If they have changed, you may get errors, as users report:
232
 https://github.com/cl-plus-ssl/cl-plus-ssl/issues/167
233
 "
234
   (detect-custom-openssl-installations-if-macos)
235
   (unless (member :cl+ssl-foreign-libs-already-loaded
236
                   *features*)
237
     (cffi:use-foreign-library libcrypto)
238
     (cffi:load-foreign-library 'libssl))
239
   (setf *ssl-global-context* nil)
240
   (setf *ssl-global-method* nil)
241
   (setf *tmp-rsa-key-512* nil)
242
   (setf *tmp-rsa-key-1024* nil))