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

Kind	Covered	All	%
expression	238	606	39.3
branch	14	64	21.9

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) 2001, 2003 Eric Marsden

4

;;; Copyright (C) 2005 David Lichteblau

5

;;; Copyright (C) 2007 Pixel // pinterface

6

;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."

7

;;; Copyright (C) contributors as per cl+ssl git history

8

;;;

9

;;; See LICENSE for details.

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

;; Default Cipher List

18

(defvar *default-cipher-list* nil)

19

20

(defparameter *default-buffer-size* 2048

21

"The default size for input and output buffers of SSL-STREAM objects")

22

23

(defclass ssl-stream

24

(trivial-gray-stream-mixin

25

fundamental-binary-input-stream

26

fundamental-binary-output-stream)

27

((ssl-stream-socket

28

:initarg :socket

29

:accessor ssl-stream-socket)

30

(close-callback

31

:initarg :close-callback

32

:accessor ssl-close-callback)

33

(handle

34

:initform nil

35

:accessor ssl-stream-handle)

36

(deadline

37

:initform nil

38

:initarg :deadline

39

:accessor ssl-stream-deadline)

40

(output-buffer

41

:accessor ssl-stream-output-buffer)

42

(output-pointer

43

:initform 0

44

:accessor ssl-stream-output-pointer)

45

(input-buffer

46

:accessor ssl-stream-input-buffer)

47

(peeked-byte

48

:initform nil

49

:accessor ssl-stream-peeked-byte)))

50

51

(defmethod initialize-instance :after ((stream ssl-stream)

52

&key

53

(buffer-size *default-buffer-size*)

54

(input-buffer-size buffer-size)

55

(output-buffer-size buffer-size)

56

&allow-other-keys)

57

(setf (ssl-stream-output-buffer stream)

58

(make-buffer output-buffer-size))

59

(setf (ssl-stream-input-buffer stream)

60

(make-buffer input-buffer-size)))

61

62

(defmethod print-object ((object ssl-stream) stream)

63

(print-unreadable-object (object stream :type t)

64

(format stream "for ~A" (ssl-stream-socket object))))

65

66

(defclass ssl-server-stream (ssl-stream)

67

((certificate

68

:initarg :certificate

69

:accessor ssl-stream-certificate)

70

(key

71

:initarg :key

72

:accessor ssl-stream-key)))

73

74

(defmethod stream-element-type ((stream ssl-stream))

75

'(unsigned-byte 8))

76

77

(defmethod close ((stream ssl-stream) &key abort)

78

(cond

79

((ssl-stream-handle stream)

80

(unless abort

81

(force-output stream)

82

(ensure-ssl-funcall stream

83

(complement #'minusp)

84

#'ssl-shutdown

85

(ssl-stream-handle stream)))

86

(ssl-free (ssl-stream-handle stream))

87

(setf (ssl-stream-handle stream) nil)

88

(when (streamp (ssl-stream-socket stream))

89

(close (ssl-stream-socket stream) :abort abort))

90

(when (ssl-close-callback stream)

91

(funcall (ssl-close-callback stream)))

92

t)

93

(t

94

nil)))

95

96

(defmethod open-stream-p ((stream ssl-stream))

97

(and (ssl-stream-handle stream) t))

98

99

(defmethod stream-listen ((stream ssl-stream))

100

(or (ssl-stream-peeked-byte stream)

101

(setf (ssl-stream-peeked-byte stream)

102

(let* ((buf (ssl-stream-input-buffer stream))

103

(handle (ssl-stream-handle stream))

104

(*bio-blockp* nil) ;; for the Lisp-BIO

105

(n (with-pointer-to-vector-data (ptr buf)

106

(nonblocking-ssl-funcall

107

stream #'plusp #'ssl-read handle ptr 1))))

108

(and (> n 0) (buffer-elt buf 0))))))

109

110

(defmethod stream-read-byte ((stream ssl-stream))

111

(or (prog1

112

(ssl-stream-peeked-byte stream)

113

(setf (ssl-stream-peeked-byte stream) nil))

114

(handler-case

115

(let ((buf (ssl-stream-input-buffer stream))

116

(handle (ssl-stream-handle stream)))

117

(with-pointer-to-vector-data (ptr buf)

118

(ensure-ssl-funcall

119

stream #'plusp #'ssl-read handle ptr 1))

120

(buffer-elt buf 0))

121

(ssl-error-zero-return () ;SSL_read returns 0 on end-of-file

122

:eof))))

123

124

(defmethod stream-read-sequence ((stream ssl-stream) seq start end &key)

125

(when (and (< start end) (ssl-stream-peeked-byte stream))

126

(setf (elt seq start) (ssl-stream-peeked-byte stream))

127

(setf (ssl-stream-peeked-byte stream) nil)

128

(incf start))

129

(let ((buf (ssl-stream-input-buffer stream))

130

(handle (ssl-stream-handle stream)))

131

(loop

132

for length = (min (- end start) (buffer-length buf))

133

while (plusp length)

134

do

135

(handler-case

136

(let ((read-bytes

137

(with-pointer-to-vector-data (ptr buf)

138

(ensure-ssl-funcall

139

stream #'plusp #'ssl-read handle ptr length))))

140

(s/b-replace seq buf :start1 start :end1 (+ start read-bytes))

141

(incf start read-bytes))

142

(ssl-error-zero-return () ;SSL_read returns 0 on end-of-file

143

(return))))

144

;; fixme: kein out-of-file wenn (zerop start)?

145

start))

146

147

(defmethod stream-write-byte ((stream ssl-stream) b)

148

(let ((buf (ssl-stream-output-buffer stream)))

149

(when (eql (buffer-length buf) (ssl-stream-output-pointer stream))

150

(force-output stream))

151

(setf (buffer-elt buf (ssl-stream-output-pointer stream)) b)

152

(incf (ssl-stream-output-pointer stream)))

153

b)

154

155

(defmacro while (cond &body body)

156

`(do () ((not ,cond)) ,@body))

157

158

(defmethod stream-write-sequence ((stream ssl-stream) seq start end &key)

159

(let ((buf (ssl-stream-output-buffer stream)))

160

(when (> (+ (- end start) (ssl-stream-output-pointer stream)) (buffer-length buf))

161

;; not enough space left? flush buffer.

162

(force-output stream)

163

;; still doesn't fit?

164

(while (> (- end start) (buffer-length buf))

165

(b/s-replace buf seq :start2 start)

166

(incf start (buffer-length buf))

167

(setf (ssl-stream-output-pointer stream) (buffer-length buf))

168

(force-output stream)))

169

(b/s-replace buf seq

170

:start1 (ssl-stream-output-pointer stream)

171

:start2 start

172

:end2 end)

173

(incf (ssl-stream-output-pointer stream) (- end start)))

174

seq)

175

176

(defmethod stream-finish-output ((stream ssl-stream))

177

(stream-force-output stream))

178

179

(defmethod stream-force-output ((stream ssl-stream))

180

(let ((buf (ssl-stream-output-buffer stream))

181

(fill-ptr (ssl-stream-output-pointer stream))

182

(handle (ssl-stream-handle stream)))

183

(when (plusp fill-ptr)

184

(unless handle

185

(error "output operation on closed SSL stream"))

186

(with-pointer-to-vector-data (ptr buf)

187

(ensure-ssl-funcall stream #'plusp #'ssl-write handle ptr fill-ptr))

188

(setf (ssl-stream-output-pointer stream) 0))))

189

190

#+(and clozure-common-lisp (not windows))

191

(defun install-nonblock-flag (fd)

192

(ccl::fd-set-flags fd (logior (ccl::fd-get-flags fd)

193

;; read-from-string is necessary because

194

;; CLISP and perhaps other Lisps are confused

195

;; by #$, signaling

196

;; "undefined dispatch character $",

197

;; even though the defun in conditionalized by

198

;; #+clozure-common-lisp

199

#.(read-from-string "#$O_NONBLOCK"))))

200

201

#+(and sbcl (not win32))

202

(defun install-nonblock-flag (fd)

203

(sb-posix:fcntl fd

204

sb-posix::f-setfl

205

(logior (sb-posix:fcntl fd sb-posix::f-getfl)

206

sb-posix::o-nonblock)))

207

208

#-(or (and clozure-common-lisp (not windows)) sbcl)

209

(defun install-nonblock-flag (fd)

210

(declare (ignore fd)))

211

212

#+(and sbcl win32)

213

(defun install-nonblock-flag (fd)

214

(when (boundp 'sockint::fionbio)

215

(sockint::ioctl fd sockint::fionbio 1)))

216

217

;;; interface functions

218

;;;

219

220

(defvar *default-unwrap-stream-p* t

221

"Default value for UNWRAP-STREAM-P function parameter.

222

223

If true (the default), cl+ssl will try to extract file descriptor

224

from the given TCP Lisp stream and tell OpenSSL to use a socket BIO

225

based on that file descriptor;

226

otherwise use a Lisp BIO wrapping the TCP Lisp stream.")

227

228

(defun install-handle-and-bio (stream handle socket unwrap-stream-p)

229

(setf (ssl-stream-handle stream) handle)

230

(when unwrap-stream-p

231

(let ((fd (stream-fd socket)))

232

(when fd

233

(setf socket fd))))

234

(etypecase socket

235

(integer

236

(install-nonblock-flag socket)

237

(ssl-set-fd handle socket))

238

(stream

239

(ssl-set-bio handle (bio-new-lisp) (bio-new-lisp))))

240

241

;; The below call setting +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ mode

242

;; existed since commit 5bd5225.

243

;; It is implemented wrong - ssl-ctx-ctrl expects

244

;; a context as the first parameter, not handle.

245

;; It was lucky to not crush on Linux and Windows,

246

;; untill crash was detedcted on OpenBSD + LibreSSL.

247

;; See https://github.com/cl-plus-ssl/cl-plus-ssl/pull/42.

248

;; We keep this code commented but not removed because

249

;; we don't know what David Lichteblau meant when

250

;; added this - maybe he has some idea?

251

;; (Although modifying global context is a bad

252

;; thing to do for install-handle-and-bio function,

253

;; also we don't see a need for movable buffer -

254

;; we don't repeat calls to ssl functions with

255

;; moved buffer).

256

;;

257

;; (ssl-ctx-ctrl handle

258

;; +SSL_CTRL_MODE+

259

;; +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+

260

;; (cffi:null-pointer))

261

262

socket)

263

264

(defun install-key-and-cert (handle key certificate)

265

(when certificate

266

(unless (eql 1 (ssl-use-certificate-file handle

267

certificate

268

+ssl-filetype-pem+))

269

(error 'ssl-error-initialize

270

:reason (format nil "Can't load certificate ~A" certificate))))

271

(when key

272

(unless (eql 1 (ssl-use-privatekey-file handle

273

key

274

+ssl-filetype-pem+))

275

(error 'ssl-error-initialize :reason (format nil "Can't load private key file ~A" key)))))

276

277

(defun x509-certificate-names (x509-certificate)

278

(unless (cffi:null-pointer-p x509-certificate)

279

(cffi:with-foreign-pointer (buf 1024)

280

(let ((issuer-name (x509-get-issuer-name x509-certificate))

281

(subject-name (x509-get-subject-name x509-certificate)))

282

(values

283

(unless (cffi:null-pointer-p issuer-name)

284

(x509-name-oneline issuer-name buf 1024)

285

(cffi:foreign-string-to-lisp buf))

286

(unless (cffi:null-pointer-p subject-name)

287

(x509-name-oneline subject-name buf 1024)

288

(cffi:foreign-string-to-lisp buf)))))))

289

290

(defmethod ssl-stream-handle ((stream flexi-streams:flexi-stream))

291

(ssl-stream-handle (flexi-streams:flexi-stream-stream stream)))

292

293

(defun ssl-stream-x509-certificate (ssl-stream)

294

(compat-ssl-get1-peer-certificate (ssl-stream-handle ssl-stream)))

295

296

(defun ssl-load-global-verify-locations (&rest pathnames)

297

"PATHNAMES is a list of pathnames to PEM files containing server and CA certificates.

298

Install these certificates to use for verifying on all SSL connections.

299

After RELOAD, you need to call this again."

300

(ensure-initialized)

301

(dolist (path pathnames)

302

(let ((namestring (namestring (truename path))))

303

(cffi:with-foreign-strings ((cafile namestring))

304

(unless (eql 1 (ssl-ctx-load-verify-locations

305

*ssl-global-context*

306

cafile

307

(cffi:null-pointer)))

308

(error "ssl-ctx-load-verify-locations failed."))))))

309

310

(defun ssl-set-global-default-verify-paths ()

311

"Load the system default verification certificates.

312

After RELOAD, you need to call this again."

313

(ensure-initialized)

314

(unless (eql 1 (ssl-ctx-set-default-verify-paths *ssl-global-context*))

315

(error "ssl-ctx-set-default-verify-paths failed.")))

316

317

(defun ssl-check-verify-p ()

318

"DEPRECATED. Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification.

319

Also, MAKE-CONTEXT has :VERIFY-MODE option.

320

321

Return true if SSL connections will error if the certificate doesn't verify."

322

(and *ssl-check-verify-p* (not (eq *ssl-check-verify-p* :unspecified))))

323

324

(defun (setf ssl-check-verify-p) (check-verify-p)

325

"DEPRECATED. Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification.

326

Also, MAKE-CONTEXT has :VERIFY-MODE option.

327

328

If CHECK-VERIFY-P is true, signal connection errors if the server certificate doesn't verify."

329

(setf *ssl-check-verify-p* (not (null check-verify-p))))

330

331

(defun ssl-verify-init (&key

332

(verify-depth nil)

333

(verify-locations nil))

334

"DEPRECATED.

335

Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification.

336

 Use (MAKE-CONTEXT ... :VERIFY-LOCATION ? :VERIFY-DEPTH ?) to control the verification depth and locations.

337

MAKE-CONTEXT also allows to enab/disable verification."

338

(check-type verify-depth (or null integer))

339

(ensure-initialized)

340

(when verify-depth

341

(ssl-ctx-set-verify-depth *ssl-global-context* verify-depth))

342

(when verify-locations

343

(apply #'ssl-load-global-verify-locations verify-locations)

344

;; This makes (setf (ssl-check-verify) nil) persistent

345

(unless (null *ssl-check-verify-p*)

346

(setf (ssl-check-verify-p) t))

347

t))

348

349

(defun maybe-verify-client-stream (ssl-stream verify-mode hostname)

350

;; VERIFY-MODE is one of NIL, :OPTIONAL, :REQUIRED

351

;; HOSTNAME is either NIL or a string.

352

(when verify-mode

353

(let* ((handle (ssl-stream-handle ssl-stream))

354

(srv-cert (compat-ssl-get1-peer-certificate handle)))

355

(unwind-protect

356

(progn

357

(when (and (eq :required verify-mode)

358

(cffi:null-pointer-p srv-cert))

359

(error 'server-certificate-missing

360

:format-control "The server didn't present a certificate."))

361

(let ((err (ssl-get-verify-result handle)))

362

(unless (eql err +x509-v-ok+)

363

(error 'ssl-error-verify :stream ssl-stream :error-code err)))

364

(when (and hostname

365

(not (cffi:null-pointer-p srv-cert)))

366

(or (verify-hostname srv-cert hostname)

367

;; verify-hostname must either return true

368

;; or signal an error

369

(error "Unexpected NIL returned by CL+SSL:VERIFY-HOSTNAME for ~A"

370

hostname))))

371

(unless (cffi:null-pointer-p srv-cert)

372

(x509-free srv-cert))))))

373

374

(defun handle-external-format (stream ef)

375

(if ef

376

(flexi-streams:make-flexi-stream stream :external-format ef)

377

stream))

378

379

(defmacro with-new-ssl ((var) &body body)

380

(alexandria:with-gensyms (ssl)

381

`(let* ((,ssl (ssl-new *ssl-global-context*))

382

(,var ,ssl))

383

(when (cffi:null-pointer-p ,ssl)

384

          (error 'ssl-error-call :message "Unable to create SSL structure" :queue (read-ssl-error-queue)))

385

(handler-bind ((error (lambda (_)

386

(declare (ignore _))

387

(ssl-free ,ssl))))

388

,@body))))

389

390

(defvar *make-ssl-client-stream-verify-default*

391

(if (member :windows *features*) ; by trivial-features

392

;; On Windows we can't yet initizlise context with

393

;; trusted certifying authorities from system configuration.

394

;; ssl-ctx-set-default-verify-paths only helps

395

;; on Unix-like platforms.

396

;; See https://github.com/cl-plus-ssl/cl-plus-ssl/issues/54.

397

nil

398

:required)

399

"Helps to mitigate the change in default behaviour of

400

MAKE-SSL-CLIENT-STREAM - previously it worked as if :VERIFY NIL

401

but then :VERIFY :REQUIRED became the default on non-Windows platforms.

402

Change this variable if you want the previous behaviour.")

403

404

(defun make-alpn-proto-string (protocols)

405

"Convert list of protocol names to the wire-format byte string."

406

(with-output-to-string (s)

407

(dolist (proto protocols)

408

(check-type proto string)

409

(write-char (code-char (length proto)) s)

410

(write-string proto s))))

411

412

;; fixme: free the context when errors happen in this function

413

(defun make-ssl-client-stream (socket

414

&key

415

(unwrap-stream-p *default-unwrap-stream-p*)

416

hostname

417

close-callback

418

external-format

419

(verify (if (ssl-check-verify-p)

420

:optional

421

                                              *make-ssl-client-stream-verify-default*))

422

alpn-protocols

423

certificate key password

424

(cipher-list *default-cipher-list*)

425

method

426

(buffer-size *default-buffer-size*)

427

(input-buffer-size buffer-size)

428

(output-buffer-size buffer-size))

429

"Performs TLS/SSL handshake over the specified SOCKET using

430

the SSL_connect OpenSSL function and returns a Lisp stream that

431

uses OpenSSL library to encrypt the output data when sending

432

it to the socket and to decrypt the input received.

433

434

Uses a global SSL_CTX instance, which can be overriden

435

by WITH-GLOBAL-CONTEXT. (The global SSL_CTX is

436

passed as a parameter to an internall call of SSL_new.)

437

438

SOCKET - represents the socket to be wrapped into an SSL stream.

439

Can be either a Lisp stream (of an implementation-dependent type) for that

440

socket, or an integer file descriptor of that socket. If that's a

441

stream, it will be closed automatically when the SSL stream

442

is closed. Also, on CCL, (CCL:STREAM-DEADLINE SOCKET) will be used

443

as a deadline for 'socket BIO' mode.

444

See README.md / Usage / Timeouts and Deadlines for more information.

445

If that's a file descriptor, it is not closed automatically

446

(you can use CLOSE-CALLBACK to arrange for that).

447

448

UNWRAP-STREAM-P - if true, (STREAM-FD SOCKET) will be attempted

449

to extract the file descriptor. Otherwise the SOCKET

450

is left as is. Anyway, if in result we end up with an integer

451

file descriptor, a socket BIO is used; if we end up with a

452

stream - Lisp BIO is used. This parameter defaults to

453

*DEFAULT-UNWRAP-STREAM-P* which is initalized to true.

454

See README.md / Usage for more information on BIO types.

455

456

HOSTNAME if specified, will be sent by client during TLS negotiation,

457

according to the Server Name Indication (SNI) extension to the TLS.

458

If we connect to a server handling multiple domain names,

459

this extension enables such server to choose certificate for the

460

right domain. Also the HOSTNAME is used for hostname verification

461

(if verification is enabled by VERIFY).

462

463

CLOSE-CALLBACK - a function to be called when the created

464

ssl stream is CL:CLOSE'ed. The only argument is this ssl stream.

465

466

EXTERNAL-FORMAT - if NIL (the default), a plain (UNSIGNED-BYTE 8)

467

ssl stream is returned. With a non-NIL external-format, a flexi-stream

468

capable of character I/O will be returned instead, with the specified

469

value as its initial external format.

470

471

VERIFY can be specified either as NIL if no check should be performed,

472

:OPTIONAL to verify the server's certificate if server presents one or

473

:REQUIRED to verify the server's certificate and fail if an invalid

474

or no certificate was presented. Defaults to

475

*MAKE-SSL-CLIENT-STREAM-VERIFY-DEFAULT* which is initialized

476

to :REQUIRED

477

478

The verification includes verifying the HOSTNAME against the server

479

ceritificate, using the VERIFY-HOSTNAME function.

480

481

An error is signalled in case of the certificate or hostname

482

verification failure.

483

484

Note, the VERIFY logic expects that the global

485

SSL_CTX object does not have the SSL_VERIFY_PEER

486

flag enabled - the default for the cl+ssl's global SSL_CTX.

487

If the current global SSL_CTX object has SSL_VERIFY_PEER enabled,

488

the SSL_Connect will perform certificate (but not hostname)

489

verification on its own, and an error will be signalled for a

490

bad certificate even with :VERIFY NIL.

491

492

ALPN-PROTOCOLS, if specified, should be a list of alpn protocol names,

493

such as \"h2\", that will be offered to the server. The protocol

494

selected by the server can be retrieved with

495

GET-SELECTED-ALPN-PROTOCOL.

496

497

CERTIFICATE is the path to a file containing a PEM-encoded certificate.

498

Note, if one certificate will be used for multiple TLS connections,

499

it's better to load it into a common SSL_CTX (context) object rather

500

than reading it for every new connection.

501

502

KEY is the path to a PEM-encoded private key file of that certificate.

503

504

PASSWORD the password to use for decryptipon of the KEY (if encrypted).

505

506

CIPHER-LIST - If not NIL, must be a string to pass to SSL_set_cipher_list.

507

An ERROR is signalled if SSL_CTX_set_cipher_list fails.

508

Defaults to *DEFAULT-CIPHER-LIST* which is initialized to NIL.

509

510

METHOD - usually you want to leave the default value. It is used

511

to compute the parameter for OpenSSL function SSL_CTX_new when

512

creating the global SSL_CTX object for cl+ssl. This parameter only has

513

effect on the first call, when the global SSL_CTX is not yet created.

514

The default value is TLS_method on OpenSSL > 1.1.0 and SSLv23_method

515

for older OpenSSL versions.

516

517

BUFFER-SIZE - default value for both the INPUT-BUFFER-SIZE and

518

OUTPUT-BUFFER-SIZE parameters. In turn defaults to the

519

*DEFAULT-BUFFER-SIZE* special variable.

520

521

INPUT-BUFFER-SIZE - size of the input buffer of the ssl stream.

522

Defaults to the BUFFER-SIZE parameter.

523

524

OUTPUT-BUFFER-SIZE - size of the output buffer of the ssl stream.

525

Defaults to the BUFFER-SIZE parameter.

526

"

527

(ensure-initialized :method method)

528

(let ((stream (make-instance 'ssl-stream

529

:socket socket

530

:close-callback close-callback

531

:input-buffer-size input-buffer-size

532

:output-buffer-size output-buffer-size)))

533

(with-new-ssl (handle)

534

(if hostname

535

(cffi:with-foreign-string (chostname hostname)

536

(ssl-set-tlsext-host-name handle chostname)))

537

(if alpn-protocols

538

(cffi:with-foreign-string ((string len) (make-alpn-proto-string alpn-protocols))

539

(ssl-set-alpn-protos handle string (1- len))))

540

(setf socket (install-handle-and-bio stream handle socket unwrap-stream-p))

541

(ssl-set-connect-state handle)

542

(when (and cipher-list

543

(zerop (ssl-set-cipher-list handle cipher-list)))

544

(error 'ssl-error-initialize

545

:reason

546

"Can't set SSL cipher list: SSL_set_cipher_list returned 0"))

547

(with-pem-password (password)

548

(install-key-and-cert handle key certificate))

549

(collecting-verify-error (handle)

550

(ensure-ssl-funcall stream #'plusp #'ssl-connect handle))

551

(maybe-verify-client-stream stream verify hostname)

552

(handle-external-format stream external-format))))

553

554

;; fixme: free the context when errors happen in this function

555

(defun make-ssl-server-stream (socket

556

&key

557

(unwrap-stream-p *default-unwrap-stream-p*)

558

close-callback

559

external-format

560

certificate key password

561

(cipher-list *default-cipher-list*)

562

method

563

(buffer-size *default-buffer-size*)

564

(input-buffer-size buffer-size)

565

(output-buffer-size buffer-size))

566

"Performs server-side TLS handshake over the specified SOCKET using

567

the SSL_accept OpenSSL function and returns a Lisp stream that

568

uses OpenSSL library to encrypt the output data when sending

569

it to the socket and to decrypt the input received.

570

571

Uses a global SSL_CTX instance, which can be overriden

572

by WITH-GLOBAL-CONTEXT. (The global SSL_CTX is

573

passed as a parameter to an internall call of SSL_new.)

574

575

All parameters have the same meaning as documented

576

for MAKE-SSL-CLIENT-STREAM.

577

"

578

(ensure-initialized :method method)

579

(let ((stream (make-instance 'ssl-server-stream

580

:socket socket

581

:close-callback close-callback

582

:certificate certificate

583

:key key

584

:input-buffer-size input-buffer-size

585

:output-buffer-size output-buffer-size)))

586

(with-new-ssl (handle)

587

(setf socket (install-handle-and-bio stream handle socket unwrap-stream-p))

588

(ssl-set-accept-state handle)

589

(when (and cipher-list

590

(zerop (ssl-set-cipher-list handle cipher-list)))

591

(error 'ssl-error-initialize

592

:reason

593

"Can't set SSL cipher list: SSL_set_cipher_list returned 0"))

594

(with-pem-password (password)

595

(install-key-and-cert handle key certificate))

596

(collecting-verify-error (handle)

597

(ensure-ssl-funcall stream #'plusp #'ssl-accept handle))

598

(handle-external-format stream external-format))))

599

600

(defun get-selected-alpn-protocol (ssl-stream)

601

"A wrapper around SSL_get0_alpn_selected.

602

Returns the ALPN protocol selected by server, or NIL if none was selected.

603

604

SSL-STREAM is the client ssl stream returned by make-ssl-client-stream. "

605

(cffi:with-foreign-objects ((ptr :pointer) (len :pointer))

606

(ssl-get0-alpn-selected (ssl-stream-handle ssl-stream) ptr len)

607

(cffi:foreign-string-to-lisp (cffi:mem-ref ptr :pointer)

608

:count (cffi:mem-ref len :int))))

609

610

(defgeneric stream-fd (stream)

611

(:documentation "The STREAM's file descriptor as an integer,

612

if known / implemented for the current lisp.

613

Otherwise the STREAM itself. The result of this function can be

614

passed to MAKE-SSL-CLIENT-STREAM and MAKE-SSL-SERVER-STREAM."))

615

(defmethod stream-fd (stream) stream)

616

617

#+sbcl

618

(defmethod stream-fd ((stream sb-sys:fd-stream))

619

(sb-sys:fd-stream-fd stream))

620

621

#+cmu

622

(defmethod stream-fd ((stream system:fd-stream))

623

(system:fd-stream-fd stream))

624

625

#+openmcl

626

(defmethod stream-fd ((stream ccl::basic-stream))

627

(ccl::ioblock-device (ccl::stream-ioblock stream t)))

628

629

#+clisp

630

(defmethod stream-fd ((stream stream))

631

;; sockets appear to be direct instances of STREAM

632

(ext:stream-handles stream))

633

634

#+ecl

635

(defmethod stream-fd ((stream two-way-stream))

636

(si:file-stream-fd (two-way-stream-input-stream stream)))

637

638

#+allegro

639

(defmethod stream-fd ((stream stream))

640

(socket:socket-os-fd stream))

641

642

#+lispworks

643

(defmethod stream-fd ((stream comm::socket-stream))

644

(comm:socket-stream-socket stream))

645

646

#+abcl

647

(progn

648

(require :abcl-contrib)

649

(require :jss)

650

651

;;; N.b. Getting the file descriptor from a socket is not supported

652

;;; by any published JVM API, so every JVM implementation may behave

653

;;; somewhat differently. By using the ability of

654

;;; jss:get-java-fields to access private fields, it is usually

655

;;; possible to "find" an access path to read the underlying integer

656

;;; value of the file decriptor, which is all we need to pass to

657

;;; SSL.

658

(defmethod stream-fd ((stream system::socket-stream))

659

(let ((errors))

660

(macrolet ((saving-error (&body body)

661

`(handler-case

662

,@body

663

(serious-condition (c)

664

(push c errors)

665

nil))))

666

(flet ((get-java-fields (object fields) ;; Thanks to Cyrus Harmon

667

(reduce (lambda (x y)

668

(jss:get-java-field x y t))

669

fields

670

:initial-value object))

671

(jvm-version ()

672

(read

673

(make-string-input-stream

674

(java:jstatic "getProperty"

675

"java.lang.System"

676

"java.specification.version")))))

677

           (let ((input-stream (java:jcall "getWrappedInputStream"  ;; TODO: define this as a constant

678

                                           (two-way-stream-input-stream stream))))

679

(or ;; starting from openjdk 14, according to Mark Evenson

680

;; in https://github.com/cl-plus-ssl/cl-plus-ssl/pull/103

681

(saving-error (get-java-fields input-stream

682

                                                '("in" "this$0" "sc" "fd" "fd")))

683

;; This seen to work for the following Java:

684

;; - On my local Linux machine

685

;; $ java -version

686

;; openjdk version "1.8.0_292"

687

                 ;;   OpenJDK Runtime Environment (Zulu 8.54.0.21-CA-linux64) (build 1.8.0_292-b10)

688

                 ;;   OpenJDK 64-Bit Server VM (Zulu 8.54.0.21-CA-linux64) (build 25.292-b10, mixed mode)

689

;; - Java 11.0.14 Debian

690

;; OpenJDK 64-Bit Server VM

691

;; (Printed by ABCL startup in GitHub Actions Linux VM

692

;; running Docker image clfoundation/cl-devel:2022-02-09)

693

(saving-error (get-java-fields input-stream

694

                                                '("in" "impl" "fd" "fd")))

695

(saving-error (get-java-fields input-stream

696

'("in" "ch" "fdVal")))

697

                 (warn "cl+ssl:stream-fd: all approaches failed. stream: ~A, jvm-version: ~S, internal input-stream: ~A, errors:~%~{~A~^~%~}"

698

stream

699

(ignore-errors (jvm-version))

700

input-stream

701

(nreverse errors)))))))))