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

KindCoveredAll%
expression97221 43.9
branch830 26.7
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
 (in-package :cl+ssl)
8
 
9
 (define-condition verify-location-not-found-error (ssl-error)
10
   ((location :initarg :location))
11
   (:documentation "Unable to find verify locations")
12
   (:report (lambda (condition stream)
13
              (format stream "Unable to find verify location. Path: ~A" (slot-value condition 'location)))))
14
 
15
 (defun validate-verify-location (location)
16
   (handler-case
17
       (cond
18
         ((uiop:file-exists-p location)
19
          (values location t))
20
         ((uiop:directory-exists-p location)
21
          (values location nil))
22
         (t
23
          (error 'verify-location-not-found-error :location location)))))
24
 
25
 (defun add-verify-locations (ssl-ctx locations)
26
   (dolist (location locations)
27
     (multiple-value-bind (location isfile)
28
         (validate-verify-location location)
29
       (cffi:with-foreign-strings ((location-ptr location))
30
         (unless (= 1 (cl+ssl::ssl-ctx-load-verify-locations
31
                       ssl-ctx
32
                       (if isfile location-ptr (cffi:null-pointer))
33
                       (if isfile (cffi:null-pointer) location-ptr)))
34
           (error 'ssl-error :queue (read-ssl-error-queue) :message (format nil "Unable to load verify location ~A" location)))))))
35
 
36
 (defun ssl-ctx-set-verify-location (ssl-ctx location)
37
   (cond
38
     ((eq :default location)
39
      (unless (= 1 (ssl-ctx-set-default-verify-paths ssl-ctx))
40
        (error 'ssl-error-call
41
               :queue (read-ssl-error-queue)
42
               :message (format nil "Unable to load default verify paths"))))
43
      ((eq :default-file location)
44
       ;; supported since openssl 1.1.0
45
       (unless (= 1 (ssl-ctx-set-default-verify-file ssl-ctx))
46
         (error 'ssl-error-call
47
                :queue (read-ssl-error-queue)
48
                :message (format nil "Unable to load default verify file"))))
49
      ((eq :default-dir location)
50
       ;; supported since openssl 1.1.0
51
       (unless (= 1 (ssl-ctx-set-default-verify-dir ssl-ctx))
52
         (error 'ssl-error-call
53
                :queue (read-ssl-error-queue)
54
                :message (format nil "Unable to load default verify dir"))))
55
     ((stringp location)
56
      (add-verify-locations ssl-ctx (list location)))
57
     ((pathnamep location)
58
      (add-verify-locations ssl-ctx (list location)))
59
     ((and location (listp location))
60
      (add-verify-locations ssl-ctx location))
61
     ;; silently allow NIL as location
62
     (location
63
      (error "Invalid location ~a" location))))
64
 
65
 (defun make-context (&key (method nil method-supplied-p)
66
                           disabled-protocols
67
                           (options (list +SSL-OP-ALL+))
68
                           min-proto-version
69
                           (session-cache-mode +ssl-sess-cache-server+)
70
                           (verify-location :default)
71
                           (verify-depth 100)
72
                           (verify-mode +ssl-verify-peer+)
73
                           verify-callback
74
                           cipher-list
75
                           (pem-password-callback 'pem-password-callback)
76
                           certificate-chain-file
77
                           private-key-file
78
                           private-key-password
79
                           (private-key-file-type +ssl-filetype-pem+))
80
   "Creates a new SSL_CTX using SSL_CTX_new and initializes it according to
81
 the specified parameters.
82
 
83
 After you're done using the context, don't forget to free it using SSL-CTX-FREE.
84
 
85
 Exceptions:
86
 
87
     SSL-ERROR-INITIALIZE. When underlying SSL_CTX_new fails.
88
 
89
 Keyword arguments:
90
 
91
     METHOD. Specifies which supported SSL/TLS to use.
92
         If not specified then TLS_method is used on OpenSSL
93
         versions supporing it (on legacy versions SSLv23_method is used).
94
 
95
     DISABLED-PROTOCOLS. List of +SSL-OP-NO-* constants. Denotes
96
         disabled SSL/TLS versions. When METHOD not specified
97
         defaults to (LIST +SSL-OP-NO-SSLV2+ +SSL-OP-NO-SSLV3+)
98
 
99
     OPTIONS. SSL context options list. Defaults to (list +SSL-OP-ALL+)
100
 
101
     SESSION-CACHE-MODE. Enable/Disable session caching.
102
         Defaults to +SSL-SESS-CACHE-SERVER+
103
 
104
     VERIFY-LOCATION. Location(s) to load CA from.
105
 
106
         Possible values:
107
             :DEFAULT - SSL_CTX_set_default_verify_paths will be called.
108
             :DEFAULT-FILE - SSL_CTX_set_default_verify_file will be called. Requires OpenSSL >= 1.1.0.
109
             :DEFAULT-DIR - SSL_CTX_set_default_verify_dir will be called. Requires OpenSSL >= 1.1.0.
110
             A STRING or a PATHNAME - will be passed to SSL_CTX_load_verify_locations
111
                 as file or dir argument depending on wether it's really
112
                 a file or a dir. Must exist on the file system and be available.
113
             A LIST - each value assumed to be either a STRING or a PATHNAME and
114
                 will be passed to SSL_CTX_load_verify_locations as described above.
115
 
116
     VERIFY-DEPTH. Sets the maximum depth for the certificate chain verification
117
         that shall be allowed for context. Defaults to 100.
118
 
119
     VERIFY-MODE. The mode parameter to SSL_CTX_set_verify.
120
         Defaults to +VERIFY-PEER+
121
 
122
     VERIFY-CALLBACK. The verify_callback parameter to SSL_CTX_set_verify.
123
         Please note: if specified, must be a CFFI callback i.e. defined as
124
         (DEFCALLBACK :INT ((OK :INT) (SSL-CTX :POINTER)) .. ).
125
 
126
     CIPHER-LIST. If specified, must be a string to pass to SSL_CTX_set_cipher_list.
127
         An ERROR is signalled if SSL_CTX_set_cipher_list fails.
128
 
129
     PEM-PASSWORD-CALLBACK. Sets the default password callback called when
130
         loading/storing a PEM certificate with encryption.
131
         Please note: this must be CFFI callback i.e. defined as
132
         (CFFI:DEFCALLBACK :INT ((BUF :POINTER) (SIZE :INT) (RWFLAG :INT) (UNUSED :POINTER)) .. ).
133
         Defaults to PEM-PASSWORD-CALLBACK which simply uses password
134
         provided by WITH-PEM-PASSWORD.
135
 "
136
   (ensure-initialized)
137
   (let ((ssl-ctx (ssl-ctx-new (if method-supplied-p
138
                                   method
139
                                   (progn
140
                                     (unless disabled-protocols
141
                                       (setf disabled-protocols
142
                                             (list +SSL-OP-NO-SSLv2+
143
                                                   +SSL-OP-NO-SSLv3+)))
144
                                     (funcall (default-ssl-method)))))))
145
     (when (cffi:null-pointer-p ssl-ctx)
146
       (error 'ssl-error-initialize :reason "Can't create new SSL-CTX"
147
                                    :queue (read-ssl-error-queue)))
148
     (handler-bind ((error (lambda (_)
149
                             (declare (ignore _))
150
                             (ssl-ctx-free ssl-ctx))))
151
       (ssl-ctx-set-options ssl-ctx
152
                            (apply #'logior
153
                                   (append disabled-protocols options)))
154
       ;; Older OpenSSL versions might not have this SSL_ctrl call.
155
       ;; Having them error out is a sane default - it's better than to keep
156
       ;; on running with insecure values.
157
       ;; People that _have_ to use much too old OpenSSL versions will
158
       ;; have to call MAKE-CONTEXT with :MIN-PROTO-VERSION nil.
159
       ;;
160
       ;; As an aside: OpenSSL had the "SSL_OP_NO_TLSv1_2" constant since
161
       ;;   7409d7ad517    2011-04-29 22:56:51 +0000
162
       ;; so requiring a "new"er OpenSSL to match CL+SSL's defauls shouldn't be a problem.
163
       (if min-proto-version
164
         (if (zerop (ssl-ctx-set-min-proto-version ssl-ctx min-proto-version))
165
           (error "Couldn't set minimum SSL protocol version!")))
166
       (ssl-ctx-set-session-cache-mode ssl-ctx session-cache-mode)
167
       (ssl-ctx-set-verify-location ssl-ctx verify-location)
168
       (ssl-ctx-set-verify-depth ssl-ctx verify-depth)
169
       (ssl-ctx-set-verify ssl-ctx verify-mode (if verify-callback
170
                                                   (cffi:get-callback verify-callback)
171
                                                   (cffi:null-pointer)))
172
 
173
       (when (and cipher-list
174
                  (zerop (ssl-ctx-set-cipher-list ssl-ctx cipher-list)))
175
         (error 'ssl-error-initialize
176
                :reason
177
                "Can't set SSL cipher list: SSL_CTX_set_cipher_list returned 0"
178
                :queue (read-ssl-error-queue)))
179
       (ssl-ctx-set-default-passwd-cb ssl-ctx (cffi:get-callback pem-password-callback))
180
       (when certificate-chain-file
181
         (ssl-ctx-use-certificate-chain-file ssl-ctx certificate-chain-file))
182
       (when private-key-file
183
         (with-pem-password (private-key-password)
184
           (ssl-ctx-use-privatekey-file ssl-ctx private-key-file private-key-file-type)))
185
       ssl-ctx)))
186
 
187
 (defun call-with-global-context (ssl-ctx auto-free-p body-fn)
188
   (let* ((*ssl-global-context* ssl-ctx))
189
     (unwind-protect (funcall body-fn)
190
       (when auto-free-p
191
         (ssl-ctx-free ssl-ctx)))))
192
 
193
 (defmacro with-global-context ((ssl-ctx &key auto-free-p) &body body)
194
   "Executes the BODY with *SSL-GLOBAL-CONTEXT* bound to the SSL-CTX.
195
 If AUTO-FREE-P is true the context is freed using SSL-CTX-FREE before exit. "
196
   `(call-with-global-context ,ssl-ctx ,auto-free-p (lambda () ,@body)))