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

KindCoveredAll%
expression46391 11.8
branch232 6.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) 2005  David Lichteblau
4
 ;;; Copyright (C) 2021  Tomas Zellerin (zellerin@gmail.com, https://github.com/zellerin)
5
 ;;; Copyright (C) 2021  Anton Vodonosov (avodonosov@yandex.ru, https://github.com/avodonosov)
6
 ;;; Copyright (C) contributors as per cl+ssl git history
7
 ;;;
8
 ;;; See LICENSE for details.
9
 
10
 (in-package cl+ssl)
11
 
12
 (defparameter *bio-blockp* t)
13
 (defvar *bio-socket*)
14
 
15
 (defvar *bio-is-opaque*
16
   "Since openssl 1.1.0, bio properties should be accessed using
17
  functions, not directly using C structure slots.
18
  Intialized to T for such openssl versions.")
19
 (defvar *lisp-bio-type*)
20
 (defvar *bio-lisp-method* nil)
21
 
22
 (defconstant +BIO_TYPE_SOURCE_SINK+ #x0400)
23
 (defconstant +BIO_TYPE_DESCRIPTOR+ #x0100)
24
 
25
 (defconstant +bio-type-socket+ (logior 5
26
                                        +BIO_TYPE_SOURCE_SINK+
27
                                        +BIO_TYPE_DESCRIPTOR+))
28
 
29
 (defconstant +BIO_CTRL_EOF+ 2)
30
 (defconstant +BIO_CTRL_FLUSH+ 11)
31
 
32
 (defconstant +BIO_FLAGS_READ+ 1)
33
 (defconstant +BIO_FLAGS_WRITE+ 2)
34
 (defconstant +BIO_FLAGS_IO_SPECIAL+ 4)
35
 (defconstant +BIO_FLAGS_RWS+ (logior +BIO_FLAGS_READ+
36
                                      +BIO_FLAGS_WRITE+
37
                                      +BIO_FLAGS_IO_SPECIAL+))
38
 (defconstant +BIO_FLAGS_SHOULD_RETRY+ 8)
39
 (defconstant +BIO_FLAGS_IN_EOF+ #x800)
40
 
41
 (cffi:defcstruct bio-method
42
   (type :int)
43
   (name :pointer)
44
   (bwrite :pointer)
45
   (bread :pointer)
46
   (bputs :pointer)
47
   (bgets :pointer)
48
   (ctrl :pointer)
49
   (create :pointer)
50
   (destroy :pointer)
51
   (callback-ctrl :pointer))
52
 
53
 (cffi:defcstruct bio
54
   (method :pointer)
55
   (callback :pointer)
56
   (cb-arg :pointer)
57
   (init :int)
58
   (shutdown :int)
59
   (flags :int)
60
   (retry-reason :int)
61
   (num :int)
62
   (ptr :pointer)
63
   (next-bio :pointer)
64
   (prev-bio :pointer)
65
   (references :int)
66
   (num-read :unsigned-long)
67
   (num-write :unsigned-long)
68
   (crypto-ex-data-stack :pointer)
69
   (crypto-ex-data-dummy :int))
70
 
71
 (defun lisp-bio-type ()
72
   (or (ignore-errors
73
         (logior (bio-new-index) +BIO_TYPE_SOURCE_SINK+))
74
       ;; Old OpenSSL and LibreSSL do not nave BIO_get_new_index,
75
       ;; in this case fallback to BIO_TYPE_SOCKET.
76
       ;; fixmy: Maybe that's wrong, but presumably still better than some
77
       ;; random value here.
78
       +bio-type-socket+))
79
 
80
 (defun make-bio-lisp-method-slots ()
81
   (let ((m (cffi:foreign-alloc '(:struct bio-method))))
82
     (setf (cffi:foreign-slot-value m '(:struct bio-method) 'type)
83
           *lisp-bio-type*)
84
     (macrolet ((slot (name)
85
                  `(cffi:foreign-slot-value m '(:struct bio-method) ,name)))
86
       (setf (slot 'name) (cffi:foreign-string-alloc "lisp"))
87
       (setf (slot 'bwrite) (cffi:callback lisp-write))
88
       (setf (slot 'bread) (cffi:callback lisp-read))
89
       (setf (slot 'bputs) (cffi:callback lisp-puts))
90
       (setf (slot 'bgets) (cffi:callback lisp-gets))
91
       (setf (slot 'ctrl) (cffi:callback lisp-ctrl))
92
       (setf (slot 'create) (cffi:callback lisp-create-slots))
93
       (setf (slot 'destroy) (cffi:callback lisp-destroy-slots))
94
       (setf (slot 'callback-ctrl) (cffi:null-pointer)))
95
     m))
96
 
97
 (defun make-bio-lisp-method-opaque ()
98
   (let ((m (bio-meth-new *lisp-bio-type* "lisp")))
99
     (bio-set-puts m (cffi:callback lisp-puts))
100
     (bio-set-write m (cffi:callback lisp-write))
101
     (bio-set-read m (cffi:callback lisp-read))
102
     (bio-set-gets m (cffi:callback lisp-gets))
103
     (bio-set-create m (cffi:callback lisp-create-opaque))
104
     (bio-set-destroy m (cffi:callback lisp-destroy-opaque))
105
     (bio-set-ctrl m (cffi:callback lisp-ctrl))
106
     m))
107
 
108
 (defun make-bio-lisp-method ()
109
   (if *bio-is-opaque*
110
       (make-bio-lisp-method-opaque)
111
       (make-bio-lisp-method-slots)))
112
 
113
 (defun bio-init ()
114
   (setf *bio-is-opaque*
115
         ;; (openssl-is-at-least 1 1) - this is not precise in case of LibreSSL,
116
         ;; therefore use the following:
117
         (not (null (cffi:foreign-symbol-pointer "BIO_get_new_index"
118
                                                 :library 'libcrypto)))
119
         *lisp-bio-type* (lisp-bio-type)
120
         *bio-lisp-method* (make-bio-lisp-method)))
121
 
122
 (defun bio-new-lisp ()
123
   (unless *bio-lisp-method* (bio-init))
124
   (let ((new (bio-new *bio-lisp-method*)))
125
     (if (or (null new) (cffi:null-pointer-p new))
126
         (error "Cannot create bio method: ~a"
127
                (cl+ssl::err-error-string (cl+ssl::err-get-error) (cffi:null-pointer)))
128
         new)))
129
 
130
 (defun bio-set-flags-slots (bio &rest flags)
131
   (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags)
132
         (logior (cffi:foreign-slot-value bio '(:struct bio) 'flags)
133
                 (apply #'logior flags))))
134
 
135
 (defun compat-bio-set-flags (bio &rest flags)
136
     (if *bio-is-opaque*
137
         (bio-set-flags bio (apply #'logior flags)) ;; FFI function since OpenSSL 1.1.0
138
         (apply #'bio-set-flags-slots bio flags)))
139
 
140
 (defun bio-clear-flags-slots (bio &rest flags)
141
   (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags)
142
         (logandc2 (cffi:foreign-slot-value bio '(:struct bio) 'flags)
143
                   (apply #'logior flags))))
144
 
145
 (defun compat-bio-clear-flags (bio &rest flags)
146
   (if *bio-is-opaque*
147
       (bio-clear-flags bio (apply #'logior flags)) ;; FFI function since OpenSSL 1.1.0
148
       (apply #'bio-clear-flags-slots bio flags)))
149
 
150
 (defun bio-test-flags-slots (bio &rest flags)
151
   (logand (cffi:foreign-slot-value bio '(:struct bio) 'flags)
152
           (apply #'logior flags)))
153
 
154
 (defun compat-bio-test-flags (bio &rest flags)
155
   (if *bio-is-opaque*
156
       (bio-test-flags bio (apply #'logior flags)) ;; FFI function since OpenSSL 1.1.0
157
       (apply #'bio-test-flags-slots bio flags)))
158
 
159
 (defun clear-retry-flags (bio)
160
   (compat-bio-clear-flags bio
161
                           +BIO_FLAGS_RWS+
162
                           +BIO_FLAGS_SHOULD_RETRY+))
163
 
164
 (defun set-retry-read (bio)
165
   (compat-bio-set-flags bio
166
                         +BIO_FLAGS_READ+
167
                         +BIO_FLAGS_SHOULD_RETRY+))
168
 
169
 
170
 ;;; Error handling for all the defcallback's:
171
 ;;;
172
 ;;; We want to avoid non-local exits across C stack,
173
 ;;; as CFFI tutorial recommends:
174
 ;;; https://common-lisp.net/project/cffi/manual/html_node/Tutorial_002dCallbacks.html.
175
 ;;;
176
 ;;; In cl+ssl this means the following nested calls:
177
 ;;;
178
 ;;;   1) Lisp: cl+ssl stream user code ->
179
 ;;;   2) C: OpenSSL C functions ->
180
 ;;;   3) Lisp: BIO implementation function
181
 ;;;        signals error and the controls is passed
182
 ;;;        to (1), without proper C cleanup.
183
 ;;;
184
 ;;; Therefore our BIO implementation functions catch all unexpected
185
 ;;; serious-conditions, arrange for BIO_should_retry
186
 ;;; to say "do not retry", and return error status (most often -1).
187
 ;;;
188
 ;;; We could try to return the real number of bytes read / written -
189
 ;;; the documentation of BIO_read and friends just says return byte
190
 ;;; number without making any special case for error:
191
 ;;;
192
 ;;; >    (...) return either the amount of data successfully read or
193
 ;;; >    written (if the return value is positive) or that no data was
194
 ;;; >    successfully read or written if the result is 0 or -1. If the
195
 ;;; >    return value is -2 then the operation is not implemented in the
196
 ;;; >    specific BIO type. The trailing NUL is not included in the length
197
 ;;; >    returned by BIO_gets().
198
 ;;;
199
 ;;; But let's not complicate the implementation, especially taking into
200
 ;;; account that we don't know how many bytes the low level
201
 ;;; Lisp function has really written before signalling
202
 ;;; the condition. Our main goal is to avoid crossing C stack,
203
 ;;; and we only consider unexpected errors here.
204
 
205
 (defparameter *file-name* (cffi:foreign-string-alloc "cl+ssl/src/bio.lisp"))
206
 
207
 (defparameter *lib-num-for-errors*
208
   (if (openssl-is-at-least 1 0 2)
209
       (err-get-next-error-library)
210
       +err_lib_none+))
211
 
212
 (defun put-to-openssl-error-queue (condition)
213
   (handler-case
214
       (let ((err-msg (format nil
215
                              "Unexpected serious-condition ~A in the Lisp BIO: ~A"
216
                              (type-of condition)
217
                              condition)))
218
         (if (openssl-is-at-least 3 0)
219
             (progn
220
               (err-new)
221
               (err-set-debug *file-name* 0 (cffi:null-pointer))
222
               #-cffi-sys::no-foreign-funcall ; because err-set-error
223
                                         ; is a vararg function
224
               (err-set-error *lib-num-for-errors*
225
                              +err_r_internal_error+
226
                              "%s"
227
                              :string err-msg))
228
             (progn
229
               (err-put-error *lib-num-for-errors*
230
                              0
231
                              +err_r_internal_error+
232
                              *file-name*
233
                              0)
234
               #-cffi-sys::no-foreign-funcall ; because err-add-error-data
235
                                         ; is a vararg function
236
               (err-add-error-data 1
237
                                   :string
238
                                   err-msg))))
239
     (serious-condition (c)
240
       (warn "~A when saving Lisp BIO error to OpenSSL error queue: ~A"
241
             (type-of c) c))))
242
 
243
 (cffi:defcallback lisp-write :int ((bio :pointer) (buf :pointer) (n :int))
244
   (handler-case
245
       (progn (dotimes (i n)
246
                (write-byte (cffi:mem-ref buf :unsigned-char i) *bio-socket*))
247
              (finish-output *bio-socket*)
248
              n)
249
     (serious-condition (c)
250
       (clear-retry-flags bio)
251
       (put-to-openssl-error-queue c)
252
       -1)))
253
 
254
 (cffi:defcallback lisp-read :int ((bio :pointer) (buf :pointer) (n :int))
255
   (handler-case
256
       (let ((i 0))
257
         (handler-case
258
             (progn
259
               (clear-retry-flags bio)
260
               (loop
261
                 while (and (< i n)
262
                            (or *bio-blockp* (listen *bio-socket*)))
263
                 do
264
                    (setf (cffi:mem-ref buf :unsigned-char i)
265
                          (read-byte *bio-socket*))
266
                    (incf i))
267
               (when (zerop i) (set-retry-read bio)))
268
           (end-of-file ()
269
             (compat-bio-set-flags bio +BIO_FLAGS_IN_EOF+)
270
             ;; now just return the number of bytes read so far
271
             ))
272
         ;; Old OpenSSL treats zero as EOF and signals an error:
273
         ;; "The TLS/SSL connection on handle #<A Foreign Pointer #x7F42DC082880> has been closed (return code: 5)"
274
         ;; despite our implementation of (BIO_ctrl ... +BIO_CTRL_EOF+)
275
         ;; returns false.
276
         ;; (This was observed on openssl-1.1.0j. And
277
         ;; on OpenSSL 3 it does not happen).
278
         ;; Since both 0 and -1 are allowed by the docs,
279
         ;; let's return -1 instead of 0.
280
         (if (= 0 i) -1 i))
281
     (serious-condition (c)
282
       (clear-retry-flags bio)
283
       (put-to-openssl-error-queue c)
284
       -1)))
285
 
286
 (cffi:defcallback lisp-gets :int ((bio :pointer) (buf :pointer) (n :int))
287
   (handler-case
288
       (let ((i 0)
289
             (max-chars (1- n)))
290
         (clear-retry-flags bio)
291
         (handler-case
292
             (loop
293
               with char
294
               and exit = nil
295
               while (and (< i max-chars)
296
                          (null exit)
297
                          (or *bio-blockp* (listen *bio-socket*)))
298
               do
299
                  (setf char (read-byte *bio-socket*)
300
                        exit (= char 10))
301
                  (setf (cffi:mem-ref buf :unsigned-char i) char)
302
                  (incf i))
303
           (end-of-file ()
304
             (compat-bio-set-flags bio +BIO_FLAGS_IN_EOF+)))
305
         (setf (cffi:mem-ref buf :unsigned-char i) 0)
306
         i)
307
     (serious-condition (c)
308
       (clear-retry-flags bio)
309
       (put-to-openssl-error-queue c)
310
       -1)))
311
 
312
 (cffi:defcallback lisp-puts :int ((bio :pointer) (buf :string))
313
   (handler-case
314
       (progn
315
         (write-line buf (flex:make-flexi-stream *bio-socket*
316
                                                 :external-format :ascii))
317
         ;; puts is not specified to return length, but BIO expects it :(
318
         (1+ (length buf)))
319
     (serious-condition (c)
320
       (clear-retry-flags bio)
321
       (put-to-openssl-error-queue c)
322
       -1)))
323
 
324
 (cffi:defcallback lisp-ctrl :int
325
     ((bio :pointer) (cmd :int) (larg :long) (parg :pointer))
326
   (declare (ignore larg parg))
327
   (cond
328
     ((eql cmd +BIO_CTRL_EOF+)
329
      (if (zerop (compat-bio-test-flags bio +BIO_FLAGS_IN_EOF+))
330
          0
331
          1))
332
     ((eql cmd +BIO_CTRL_FLUSH+) 1)
333
     (t
334
      ;; (warn "lisp-ctrl(~A,~A,~A)" cmd larg parg)
335
      0)))
336
 
337
 ;;; The create and destroy handlers mostly consist
338
 ;;; of setting zero values to some BIO fields,
339
 ;;; which seem redundant, because OpenSSl most likely
340
 ;;; does this itself. But we follow example of the
341
 ;;; standard OpenSSL BIO types implementation.
342
 ;;; Like the file_new / file_free here:
343
 ;;; https://github.com/openssl/openssl/blob/4ccad35756dfa9df657f3853810101fa9d6ca525/crypto/bio/bss_file.c#L109
344
 
345
 (cffi:defcallback lisp-create-slots :int ((bio :pointer))
346
   (handler-case
347
       (progn
348
         (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 1) ; the only useful thing?
349
         (setf (cffi:foreign-slot-value bio '(:struct bio) 'num) 0)
350
         (setf (cffi:foreign-slot-value bio '(:struct bio) 'ptr) (cffi:null-pointer))
351
         (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0)
352
         1)
353
     (serious-condition (c)
354
       (put-to-openssl-error-queue c)
355
       0)))
356
 
357
 (cffi:defcallback lisp-create-opaque :int ((bio :pointer))
358
   (handler-case
359
       (progn
360
         (bio-set-init bio 1) ; the only useful thing?
361
         (clear-retry-flags bio)
362
         1)
363
     (serious-condition (c)
364
       (put-to-openssl-error-queue c)
365
       0)))
366
 
367
 (cffi:defcallback lisp-destroy-slots :int ((bio :pointer))
368
   (handler-case
369
       (cond
370
         ((cffi:null-pointer-p bio) 0)
371
         (t
372
          (setf (cffi:foreign-slot-value bio '(:struct bio) 'init) 0)
373
          (setf (cffi:foreign-slot-value bio '(:struct bio) 'flags) 0)
374
          1))
375
     (serious-condition (c)
376
       (put-to-openssl-error-queue c)
377
       0)))
378
 
379
 (cffi:defcallback lisp-destroy-opaque :int ((bio :pointer))
380
   (handler-case
381
       (cond
382
         ((cffi:null-pointer-p bio) 0)
383
         (t
384
          (bio-set-init bio 0)
385
          (clear-retry-flags bio)
386
          1))
387
     (serious-condition (c)
388
       (put-to-openssl-error-queue c)
389
       0)))
390
 
391
 ;;; Convenience macros
392
 (defmacro with-bio-output-to-string ((bio &key
393
                                             (element-type ''character)
394
                                             (transformer '#'code-char))
395
                                      &body body)
396
   "Evaluate BODY with BIO bound to a SSL BIO structure that writes to a
397
 Common Lisp string.  The string is returned."
398
   `(let ((*bio-socket* (flex:make-in-memory-output-stream :element-type ,element-type
399
                                                           :transformer ,transformer))
400
          (,bio (bio-new-lisp)))
401
      (unwind-protect
402
           (progn ,@body)
403
        (bio-free ,bio))
404
      (flex:get-output-stream-sequence *bio-socket*)))
405
 
406
 (defmacro with-bio-input-from-string ((bio
407
                                        string
408
                                        &key (transformer '#'char-code))
409
                                       &body body)
410
   "Evaluate BODY with BIO bound to a SSL BIO structure that reads from
411
 a Common Lisp STRING."
412
   `(let ((*bio-socket* (flex:make-in-memory-input-stream ,string
413
                                                          :transformer ,transformer))
414
          (,bio (bio-new-lisp)))
415
      (unwind-protect
416
           (progn ,@body)
417
        (bio-free ,bio))))
418
 
419
 (setf *bio-lisp-method* nil)    ;force reinit if anything changed here