Coverage report: /home/ellis/comp/core/lib/cry/ssl/rls.lisp

KindCoveredAll%
expression0256 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; rls.lisp --- Rustls High-level API
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :ssl)
7
 
8
 ;;; Conditions
9
 (define-condition rls-condition (ssl-condition) ())
10
 (define-condition rls-error (ssl-error) ())
11
 
12
 ;;; Crypto Provider
13
 (defvar *crypto-provider* nil)
14
 
15
 (defun init-rls ()
16
   "Initialize RLS - ensures rustls shared library is loaded and that the default
17
 crypto provider is initialized for the current process."
18
   (load-rustls)
19
   (with-alien ((b (* rustls::rustls-crypto-provider-builder)))
20
     (rustls::rustls-crypto-provider-builder-new-from-default (addr b))
21
     (values (setf *crypto-provider* (rustls-crypto-provider-default))
22
             (rustls:rustls-result* (rustls::rustls-crypto-provider-builder-build-as-default b)))))
23
 
24
 ;;; Keys
25
 (defun build-rls-certified-key (cert-chain private-key 
26
                                 &optional signing-key (provider (rustls-crypto-provider-default)))
27
   "Build and return a RUSTLS-CERTIFIED-KEY alien. Typically used to create a
28
 RUSTLS-SERVER-CONFIG and then immediately called with
29
 RUSTLS-CERTIFIED-KEY-FREE. This will transfer ownership of the key to the
30
 config, which will be freed automatically when RUSTLS-SERVER-CONFIG-FREE is
31
 called.
32
 
33
 CERT-CHAIN is an octet-vector containing a series of PEM-encoded certs, with
34
 the end-entity (leaf) certificate first.
35
 
36
 PRIVATE-KEY is an octet-vector containing a PEM-encoded private key in either
37
 PKCS#1, PKCS#8 or SEC#1 when compiled with default settings (aws-lc-rs as
38
 crypto provider).
39
 
40
 Optional SIGNING-KEY is an octet-vector containing the PEM-encoded signing
41
 key, passed to RUSTLS-CRYPTO-PROVIDER-LOAD-KEY using the PROVIDER."
42
   (let ((cl (length cert-chain)) (pl (length private-key)))
43
     (with-static-vectors ((c cl :initial-contents cert-chain)
44
                           (p pl :initial-contents private-key))
45
       (with-alien ((out (* rustls-certified-key)))
46
         (if signing-key
47
             (with-alien ((kout (* rustls-signing-key)))
48
               (let ((kres (rustls-result* 
49
                            (rustls-crypto-provider-load-key 
50
                             provider 
51
                             (static-vector-pointer p) pl 
52
                             (addr kout)))))
53
                 (if (eql kres :ok)
54
                     (values 
55
                      out
56
                      (rustls-result* 
57
                       (rustls-certified-key-build 
58
                        (static-vector-pointer c) cl 
59
                        (static-vector-pointer p) pl 
60
                        (addr out))))
61
                     (values kout kres))))
62
             (values 
63
              out
64
              (rustls-result* 
65
               (rustls-certified-key-build 
66
                (static-vector-pointer c) cl 
67
                (static-vector-pointer p) pl 
68
                (addr out)))))))))
69
 
70
 ;;; Connection
71
 (defstruct rls-connection 
72
   (sap nil))
73
 
74
 (defaccessor sap ((self rls-connection)) (rls-connection-sap self))
75
 
76
 ;;; Client
77
 (defconfig rls-client-config ()
78
   ((sap :initform nil :initarg :sap :accessor sap)
79
    (root-store :initform nil :initarg :root-store :accessor root-store)
80
    ;; key_log or key_log_file?
81
    (server-verifier :initarg :server-verifier :accessor server-verifier)
82
    ;; verifier?
83
    (enable-sni :initform nil :initarg :enable-sni :accessor enable-sni)
84
    (certified-keys :initform nil :initarg :certified-keys :accessor certified-keys)))
85
 
86
 (defmethod connect ((self rls-client-config) server-name)
87
   (with-alien ((conn (* rustls::rustls-connection)))
88
     (values
89
      conn
90
      (rustls::rustls-result* (rustls::rustls-client-connection-new (sap self) server-name (addr conn))))))
91
             
92
 (defmethod build ((self rls-client-config) &key root-store certified-keys key-log-file)
93
   (let ((cbuilder (rustls::rustls-client-config-builder-new)))
94
     (when key-log-file
95
       (sb-posix:setenv "SSLKEYLOGFILE" key-log-file 1)
96
       (rustls:rustls-client-config-builder-set-key-log-file cbuilder))
97
     (with-alien ((cout (* rustls::rustls-client-config))
98
                  (ver (* rustls::rustls-server-cert-verifier)))
99
       (rustls::rustls-result* (rustls::rustls-platform-server-cert-verifier (addr ver)))
100
       (setf (sap self) cout
101
             (root-store self) root-store
102
             (certified-keys self) certified-keys)
103
       (rustls::rustls-client-config-builder-set-server-verifier cbuilder ver)
104
       (values 
105
        self
106
        (rustls-result* (rustls::rustls-client-config-builder-build cbuilder (addr cout)))))))
107
 
108
 ;;; Callbacks
109
 (define-alien-callable default-rls-hello-callback (* rustls-certified-key)
110
     ((userdata rustls-client-hello-userdata)
111
      (hello (* rustls-client-hello)))
112
   (with-alien ((out (* rustls-certified-key)))
113
     (rustls-certified-key-build nil 0 nil 0 (addr out))
114
     out))
115
 
116
 (defun make-rls-hello-callback (fn)
117
   (declare (ignore fn))
118
   (alien-callable-function 'default-rls-hello-callback))
119
 
120
 (defstruct rls-server-persistence 
121
   "A struct containing the three required functions for Rustls TLS session ID and
122
 secrets persistence."
123
   (get (required-argument :get) :type function) 
124
   (put (required-argument :put) :type function))
125
 
126
 ;; (defclass rls-session-store () ())
127
 
128
 (defun make-rls-session-store-get-callback (fn)
129
   (declare (ignore fn))
130
   (alien-callable-function 'default-rls-session-store-get-callback))
131
 
132
 (define-alien-callable default-rls-session-store-get-callback unsigned-int
133
     ((userdata rustls-session-store-userdata)
134
      (key (* rustls-slice-bytes))
135
      (remove-after int)
136
      (buf (* unsigned-char))
137
      (count size-t)
138
      (out-n (* size-t)))
139
   0)
140
 
141
 (defun make-rls-session-store-put-callback (fn)
142
   (declare (ignore fn))
143
   (alien-callable-function 'default-rls-session-store-put-callback))
144
 
145
 (define-alien-callable default-rls-session-store-put-callback unsigned-int
146
     ((userdata rustls-session-store-userdata)
147
      (key (* rustls-slice-bytes))
148
      (val (* rustls-slice-bytes)))
149
   0)
150
 
151
 (defun make-rls-session-store-callbacks (self)
152
   (values (make-rls-session-store-get-callback (rls-server-persistence-get self))
153
           (make-rls-session-store-put-callback (rls-server-persistence-put self))))
154
 
155
 ;;; Server
156
 (defconfig rls-server-config ()
157
   ((sap :initform nil :initarg :sap :accessor sap)
158
    (hello :initarg :hello :type function)
159
    (client-verifier :initarg :client-verifier :initform nil)
160
    ;; key_log or key_log_file?
161
    (ignore-client-order :initform nil :type boolean :initarg :ignore-client-order)
162
    (alpn-protocols :initform nil :type list :initarg :alpn-protocols)
163
    (certified-keys :initform nil :type list :initarg :certified-keys)
164
    (persistence :type rls-server-persistence :initarg :persistence
165
     :documentation "Callbacks for persistence of TLS session IDs and secrets.")))
166
 
167
 (defmethod build ((self rls-server-config) &key)
168
   (let ((cbuilder (rustls::rustls-server-config-builder-new)))
169
     (with-alien ((cout (* rustls::rustls-server-config)))
170
       (when (slot-boundp self 'hello)
171
         (rustls-server-config-builder-set-hello-callback 
172
          cbuilder 
173
          (make-rls-hello-callback (slot-value self 'hello))))
174
       (when (slot-boundp self 'ignore-client-order)
175
         (rustls-server-config-builder-set-ignore-client-order cbuilder (slot-value self 'ignore-client-order)))
176
       (when (slot-boundp self 'client-verifier)
177
         (rustls-server-config-builder-set-client-verifier cbuilder (sap (slot-value self 'client-verifier))))
178
       (when (slot-boundp self 'persistence)
179
         (multiple-value-bind (get-cb put-cb) (make-rls-session-store-callbacks (slot-value self 'persistence))
180
           (rustls-server-config-builder-set-persistence
181
            cbuilder get-cb put-cb)))
182
       (setf (sap self) cout)
183
       (values 
184
        self
185
        (rustls-result* (rustls::rustls-server-config-builder-build cbuilder (addr cout)))))))
186
 
187
 #|
188
  * The root cert store can be used in several `rustls_web_pki_client_cert_verifier_builder_new`
189
  * instances and must be freed by the application when no longer needed. See the documentation of
190
  * `rustls_root_cert_store_free` for details about lifetime.
191
 |#
192
 ;;; Root Cert Store
193
 (defclass rls-root-cert-store () 
194
   ((certs :initarg :certs :initform nil)
195
    (strict :initarg :strict :initform nil)))
196
 
197
 (defmethod build ((self rls-root-cert-store) &key) ()
198
   (let ((sbuilder (rustls::rustls-root-cert-store-builder-new)))
199
     (when-let ((certs (slot-value self 'certs)))
200
       (let ((strict (slot-value self 'strict)))
201
         (dolist (c certs)
202
           (etypecase c
203
             (pathname (rustls-root-cert-store-builder-load-roots-from-file sbuilder (namestring c) strict))
204
             (string 
205
              (rustls-root-cert-store-builder-add-pem 
206
               sbuilder 
207
               (octets-to-alien (sb-ext:string-to-octets c)) (length c) 
208
               strict))
209
             (octet-vector 
210
              (rustls-root-cert-store-builder-add-pem 
211
               sbuilder 
212
               (octets-to-alien c) (length c) 
213
               strict))))))
214
     (sb-alien:with-alien ((sc (* rustls::rustls-root-cert-store)))
215
       (unwind-protect (values sc (rustls::rustls-root-cert-store-builder-build sbuilder (sb-alien:addr sc)))
216
         (rustls::rustls-root-cert-store-builder-free sbuilder)))))
217
 
218
 ;;; Client Cert Verifier
219
 (defclass rls-client-cert-verifier ()
220
   ((sap :initform nil :initarg :sap :accessor sap)
221
    (crls :initform nil :initarg :crls)
222
    (end-entity-only :initform nil :initarg :end-entity-only :type boolean)
223
    (allow-unknown-revocation-status :initform nil :initarg :allow-unknown-revocation-status :type boolean)
224
    (allow-unauthenticated :initform nil :initarg :allow-unauthenticated)))
225
 
226
 (defclass rls-web-pki-client-cert-verifier (rls-client-cert-verifier) ())
227
 
228
 (defmethod build ((self rls-web-pki-client-cert-verifier) &key store) ()
229
   (let ((builder (rustls::rustls-web-pki-client-cert-verifier-builder-new store)))
230
     (sb-alien:with-alien ((out (* rustls-web-pki-client-cert-verifier)))
231
       (setf (sap self) out)
232
       (unwind-protect (values self (rustls-result*
233
                                     (rustls::rustls-web-pki-client-cert-verifier-builder-build 
234
                                      builder
235
                                      (addr out))))
236
         (rustls::rustls-web-pki-client-cert-verifier-builder-free builder)))))
237
 
238
 (defclass rls-server-cert-verifier ()
239
   ((sap :initform nil :initarg :sap :accessor sap)
240
    (crls :initform nil :initarg :crls)
241
    (end-entity-only :initform nil :initarg :end-entity-only :type boolean)
242
    (allow-unknown-revocation-status :initform nil :initarg :allow-unknown-revocation-status :type boolean)
243
    (allow-unauthenticated :initform nil :initarg :allow-unauthenticated)))
244
 
245
 (defclass rls-web-pki-server-cert-verifier (rls-server-cert-verifier) ())
246
 
247
 (defclass rls-platform-server-cert-verifier (rls-server-cert-verifier) ())