3rdparties/software/cl+ssl-20200427-git/src/streams.lisp (19330 bytes)
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 ;;; 8 ;;; See LICENSE for details. 9 10 #+xcvb 11 (module 12 (:depends-on ("package" "conditions" "ffi" 13 (:cond ((:featurep :clisp) "ffi-buffer-clisp") 14 (t "ffi-buffer")) 15 "ffi-buffer-all"))) 16 17 (eval-when (:compile-toplevel) 18 (declaim 19 (optimize (speed 3) (space 1) (safety 1) (debug 0) (compilation-speed 0)))) 20 21 (in-package :cl+ssl) 22 23 ;; Default Cipher List 24 (defvar *default-cipher-list* "ALL") 25 26 (defclass ssl-stream 27 (trivial-gray-stream-mixin 28 fundamental-binary-input-stream 29 fundamental-binary-output-stream) 30 ((ssl-stream-socket 31 :initarg :socket 32 :accessor ssl-stream-socket) 33 (close-callback 34 :initarg :close-callback 35 :accessor ssl-close-callback) 36 (handle 37 :initform nil 38 :accessor ssl-stream-handle) 39 (deadline 40 :initform nil 41 :initarg :deadline 42 :accessor ssl-stream-deadline) 43 (output-buffer 44 :initform (make-buffer +initial-buffer-size+) 45 :accessor ssl-stream-output-buffer) 46 (output-pointer 47 :initform 0 48 :accessor ssl-stream-output-pointer) 49 (input-buffer 50 :initform (make-buffer +initial-buffer-size+) 51 :accessor ssl-stream-input-buffer) 52 (peeked-byte 53 :initform nil 54 :accessor ssl-stream-peeked-byte))) 55 56 (defmethod print-object ((object ssl-stream) stream) 57 (print-unreadable-object (object stream :type t) 58 (format stream "for ~A" (ssl-stream-socket object)))) 59 60 (defclass ssl-server-stream (ssl-stream) 61 ((certificate 62 :initarg :certificate 63 :accessor ssl-stream-certificate) 64 (key 65 :initarg :key 66 :accessor ssl-stream-key))) 67 68 (defmethod stream-element-type ((stream ssl-stream)) 69 '(unsigned-byte 8)) 70 71 (defmethod close ((stream ssl-stream) &key abort) 72 (cond 73 ((ssl-stream-handle stream) 74 (unless abort 75 (force-output stream)) 76 (ssl-free (ssl-stream-handle stream)) 77 (setf (ssl-stream-handle stream) nil) 78 (when (streamp (ssl-stream-socket stream)) 79 (close (ssl-stream-socket stream))) 80 (when (ssl-close-callback stream) 81 (funcall (ssl-close-callback stream))) 82 t) 83 (t 84 nil))) 85 86 (defmethod open-stream-p ((stream ssl-stream)) 87 (and (ssl-stream-handle stream) t)) 88 89 (defmethod stream-listen ((stream ssl-stream)) 90 (or (ssl-stream-peeked-byte stream) 91 (setf (ssl-stream-peeked-byte stream) 92 (let* ((buf (ssl-stream-input-buffer stream)) 93 (handle (ssl-stream-handle stream)) 94 (*blockp* nil) ;; for the Lisp-BIO 95 (n (with-pointer-to-vector-data (ptr buf) 96 (nonblocking-ssl-funcall 97 stream handle #'ssl-read handle ptr 1)))) 98 (and (> n 0) (buffer-elt buf 0)))))) 99 100 (defmethod stream-read-byte ((stream ssl-stream)) 101 (or (prog1 102 (ssl-stream-peeked-byte stream) 103 (setf (ssl-stream-peeked-byte stream) nil)) 104 (handler-case 105 (let ((buf (ssl-stream-input-buffer stream)) 106 (handle (ssl-stream-handle stream))) 107 (with-pointer-to-vector-data (ptr buf) 108 (ensure-ssl-funcall 109 stream handle #'ssl-read handle ptr 1)) 110 (buffer-elt buf 0)) 111 (ssl-error-zero-return () ;SSL_read returns 0 on end-of-file 112 :eof)))) 113 114 (defmethod stream-read-sequence ((stream ssl-stream) seq start end &key) 115 (when (and (< start end) (ssl-stream-peeked-byte stream)) 116 (setf (elt seq start) (ssl-stream-peeked-byte stream)) 117 (setf (ssl-stream-peeked-byte stream) nil) 118 (incf start)) 119 (let ((buf (ssl-stream-input-buffer stream)) 120 (handle (ssl-stream-handle stream))) 121 (loop 122 for length = (min (- end start) (buffer-length buf)) 123 while (plusp length) 124 do 125 (handler-case 126 (let ((read-bytes 127 (with-pointer-to-vector-data (ptr buf) 128 (ensure-ssl-funcall 129 stream handle #'ssl-read handle ptr length)))) 130 (s/b-replace seq buf :start1 start :end1 (+ start read-bytes)) 131 (incf start read-bytes)) 132 (ssl-error-zero-return () ;SSL_read returns 0 on end-of-file 133 (return)))) 134 ;; fixme: kein out-of-file wenn (zerop start)? 135 start)) 136 137 (defmethod stream-write-byte ((stream ssl-stream) b) 138 (let ((buf (ssl-stream-output-buffer stream))) 139 (when (eql (buffer-length buf) (ssl-stream-output-pointer stream)) 140 (force-output stream)) 141 (setf (buffer-elt buf (ssl-stream-output-pointer stream)) b) 142 (incf (ssl-stream-output-pointer stream))) 143 b) 144 145 (defmethod stream-write-sequence ((stream ssl-stream) seq start end &key) 146 (let ((buf (ssl-stream-output-buffer stream))) 147 (when (> (+ (- end start) (ssl-stream-output-pointer stream)) (buffer-length buf)) 148 ;; not enough space left? flush buffer. 149 (force-output stream) 150 ;; still doesn't fit? 151 (while (> (- end start) (buffer-length buf)) 152 (b/s-replace buf seq :start2 start) 153 (incf start (buffer-length buf)) 154 (setf (ssl-stream-output-pointer stream) (buffer-length buf)) 155 (force-output stream))) 156 (b/s-replace buf seq 157 :start1 (ssl-stream-output-pointer stream) 158 :start2 start 159 :end2 end) 160 (incf (ssl-stream-output-pointer stream) (- end start))) 161 seq) 162 163 (defmethod stream-finish-output ((stream ssl-stream)) 164 (stream-force-output stream)) 165 166 (defmethod stream-force-output ((stream ssl-stream)) 167 (let ((buf (ssl-stream-output-buffer stream)) 168 (fill-ptr (ssl-stream-output-pointer stream)) 169 (handle (ssl-stream-handle stream))) 170 (when (plusp fill-ptr) 171 (unless handle 172 (error "output operation on closed SSL stream")) 173 (with-pointer-to-vector-data (ptr buf) 174 (ensure-ssl-funcall stream handle #'ssl-write handle ptr fill-ptr)) 175 (setf (ssl-stream-output-pointer stream) 0)))) 176 177 #+(and clozure-common-lisp (not windows)) 178 (defun install-nonblock-flag (fd) 179 (ccl::fd-set-flags fd (logior (ccl::fd-get-flags fd) 180 #.(read-from-string "#$O_NONBLOCK")))) 181 ;; read-from-string is necessary because 182 ;; CLISP and perhaps other Lisps are confused 183 ;; by #$, signaling"undefined dispatch character $", 184 ;; even though the defun in conditionalized by 185 ;; #+clozure-common-lisp 186 187 #+(and sbcl (not win32)) 188 (defun install-nonblock-flag (fd) 189 (sb-posix:fcntl fd 190 sb-posix::f-setfl 191 (logior (sb-posix:fcntl fd sb-posix::f-getfl) 192 sb-posix::o-nonblock))) 193 194 #-(or (and clozure-common-lisp (not windows)) sbcl) 195 (defun install-nonblock-flag (fd) 196 (declare (ignore fd))) 197 198 #+(and sbcl win32) 199 (defun install-nonblock-flag (fd) 200 (when (boundp 'sockint::fionbio) 201 (sockint::ioctl fd sockint::fionbio 1))) 202 203 ;;; interface functions 204 ;;; 205 206 (defun install-handle-and-bio (stream handle socket unwrap-stream-p) 207 (setf (ssl-stream-handle stream) handle) 208 (when unwrap-stream-p 209 (let ((fd (stream-fd socket))) 210 (when fd 211 (setf socket fd)))) 212 (etypecase socket 213 (integer 214 (install-nonblock-flag socket) 215 (ssl-set-fd handle socket)) 216 (stream 217 (ssl-set-bio handle (bio-new-lisp) (bio-new-lisp)))) 218 219 ;; The below call setting +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ mode 220 ;; existed since commit 5bd5225. 221 ;; It is implemented wrong - ssl-ctx-ctrl expects 222 ;; a context as the first parameter, not handle. 223 ;; It was lucky to not crush on Linux and Windows, 224 ;; untill crash was detedcted on OpenBSD + LibreSSL. 225 ;; See https://github.com/cl-plus-ssl/cl-plus-ssl/pull/42. 226 ;; We keep this code commented but not removed because 227 ;; we don't know what David Lichteblau meant when 228 ;; added this - maybe he has some idea? 229 ;; (Although modifying global context is a bad 230 ;; thing to do for install-handle-and-bio function, 231 ;; also we don't see a need for movable buffer - 232 ;; we don't repeat calls to ssl functions with 233 ;; moved buffer). 234 ;; 235 ;; (ssl-ctx-ctrl handle 236 ;; +SSL_CTRL_MODE+ 237 ;; +SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER+ 238 ;; (cffi:null-pointer)) 239 240 socket) 241 242 (defun install-key-and-cert (handle key certificate) 243 (when certificate 244 (unless (eql 1 (ssl-use-certificate-file handle 245 certificate 246 +ssl-filetype-pem+)) 247 (error 'ssl-error-initialize 248 :reason (format nil "Can't load certificate ~A" certificate)))) 249 (when key 250 (unless (eql 1 (ssl-use-privatekey-file handle 251 key 252 +ssl-filetype-pem+)) 253 (error 'ssl-error-initialize :reason (format nil "Can't load private key file ~A" key))))) 254 255 (defun x509-certificate-names (x509-certificate) 256 (unless (cffi:null-pointer-p x509-certificate) 257 (cffi:with-foreign-pointer (buf 1024) 258 (let ((issuer-name (x509-get-issuer-name x509-certificate)) 259 (subject-name (x509-get-subject-name x509-certificate))) 260 (values 261 (unless (cffi:null-pointer-p issuer-name) 262 (x509-name-oneline issuer-name buf 1024) 263 (cffi:foreign-string-to-lisp buf)) 264 (unless (cffi:null-pointer-p subject-name) 265 (x509-name-oneline subject-name buf 1024) 266 (cffi:foreign-string-to-lisp buf))))))) 267 268 (defmethod ssl-stream-handle ((stream flexi-streams:flexi-stream)) 269 (ssl-stream-handle (flexi-streams:flexi-stream-stream stream))) 270 271 (defun ssl-stream-x509-certificate (ssl-stream) 272 (ssl-get-peer-certificate (ssl-stream-handle ssl-stream))) 273 274 (defun ssl-load-global-verify-locations (&rest pathnames) 275 "PATHNAMES is a list of pathnames to PEM files containing server and CA certificates. 276 Install these certificates to use for verifying on all SSL connections. 277 After RELOAD, you need to call this again." 278 (ensure-initialized) 279 (dolist (path pathnames) 280 (let ((namestring (namestring (truename path)))) 281 (cffi:with-foreign-strings ((cafile namestring)) 282 (unless (eql 1 (ssl-ctx-load-verify-locations 283 *ssl-global-context* 284 cafile 285 (cffi:null-pointer))) 286 (error "ssl-ctx-load-verify-locations failed.")))))) 287 288 (defun ssl-set-global-default-verify-paths () 289 "Load the system default verification certificates. 290 After RELOAD, you need to call this again." 291 (ensure-initialized) 292 (unless (eql 1 (ssl-ctx-set-default-verify-paths *ssl-global-context*)) 293 (error "ssl-ctx-set-default-verify-paths failed."))) 294 295 (defun ssl-check-verify-p () 296 "DEPRECATED. Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification. 297 MAKE-CONTEXT also allows to enab/disable verification. 298 299 Return true if SSL connections will error if the certificate doesn't verify." 300 (and *ssl-check-verify-p* (not (eq *ssl-check-verify-p* :unspecified)))) 301 302 (defun (setf ssl-check-verify-p) (check-verify-p) 303 "DEPRECATED. Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification. 304 MAKE-CONTEXT also allows to enab/disable verification. 305 306 If CHECK-VERIFY-P is true, signal connection errors if the server certificate doesn't verify." 307 (setf *ssl-check-verify-p* (not (null check-verify-p)))) 308 309 (defun ssl-verify-init (&key 310 (verify-depth nil) 311 (verify-locations nil)) 312 "DEPRECATED. 313 Use the (MAKE-SSL-CLIENT-STREAM .. :VERIFY ?) to enable/disable verification. 314 Use (MAKE-CONTEXT ... :VERIFY-LOCATION ? :VERIFY-DEPTH ?) to control the verification depth and locations. 315 MAKE-CONTEXT also allows to enab/disable verification." 316 (check-type verify-depth (or null integer)) 317 (ensure-initialized) 318 (when verify-depth 319 (ssl-ctx-set-verify-depth *ssl-global-context* verify-depth)) 320 (when verify-locations 321 (apply #'ssl-load-global-verify-locations verify-locations) 322 ;; This makes (setf (ssl-check-verify) nil) persistent 323 (unless (null *ssl-check-verify-p*) 324 (setf (ssl-check-verify-p) t)) 325 t)) 326 327 (defun maybe-verify-client-stream (ssl-stream verify-mode hostname) 328 ;; VERIFY-MODE is one of NIL, :OPTIONAL, :REQUIRED 329 ;; HOSTNAME is either NIL or a string. 330 (when verify-mode 331 (let* ((handle (ssl-stream-handle ssl-stream)) 332 (srv-cert (ssl-get-peer-certificate handle))) 333 (unwind-protect 334 (progn 335 (when (and (eq :required verify-mode) 336 (cffi:null-pointer-p srv-cert)) 337 (error 'server-certificate-missing 338 :format-control "The server didn't present a certificate.")) 339 (let ((err (ssl-get-verify-result handle))) 340 (unless (eql err 0) 341 (error 'ssl-error-verify :stream ssl-stream :error-code err))) 342 (when (and hostname 343 (not (cffi:null-pointer-p srv-cert)) 344 ;; Beware of the unusual protocol of verify-hostname: 345 ;; it returns the verification result as true / false, 346 ;; but also signals error for many verification failures. 347 ;; TODO: refactor verify-hostname to simplify this protocol. 348 (not (verify-hostname srv-cert hostname))) 349 (error 'ssl-unable-to-match-host-name :hostname hostname)))) 350 (unless (cffi:null-pointer-p srv-cert) 351 (x509-free srv-cert))))) 352 353 (defun handle-external-format (stream ef) 354 (if ef 355 (flexi-streams:make-flexi-stream stream :external-format ef) 356 stream)) 357 358 (defmacro with-new-ssl ((var) &body body) 359 (alexandria:with-gensyms (ssl) 360 `(let* ((,ssl (ssl-new *ssl-global-context*)) 361 (,var ,ssl)) 362 (when (cffi:null-pointer-p ,ssl) 363 (error 'ssl-error-call :message "Unable to create SSL structure" :queue (read-ssl-error-queue))) 364 (handler-bind ((error (lambda (_) 365 (declare (ignore _)) 366 (ssl-free ,ssl)))) 367 ,@body)))) 368 369 (defvar *make-ssl-client-stream-verify-default* 370 (if (member :windows *features*) ; by trivial-features 371 ;; On Windows we can't yet initizlise context with 372 ;; trusted certifying authorities from system configuration. 373 ;; ssl-ctx-set-default-verify-paths only helps 374 ;; on Unix-like platforms. 375 ;; See https://github.com/cl-plus-ssl/cl-plus-ssl/issues/54. 376 nil 377 :required) 378 "Helps to mitigate the change in default behaviour of 379 MAKE-SSL-CLIENT-STREAM - previously it worked as if :VERIFY NIL 380 but then :VERIFY :REQUIRED became the default on non-Windows platforms. 381 Change this variable if you want the previous behaviour.") 382 383 ;; fixme: free the context when errors happen in this function 384 (defun make-ssl-client-stream 385 (socket &key certificate key password method external-format 386 close-callback (unwrap-stream-p t) 387 (cipher-list *default-cipher-list*) 388 (verify (if (ssl-check-verify-p) 389 :optional 390 *make-ssl-client-stream-verify-default*)) 391 hostname) 392 "Returns an SSL stream for the client socket descriptor SOCKET. 393 CERTIFICATE is the path to a file containing the PEM-encoded certificate for 394 your client. KEY is the path to the PEM-encoded key for the client, which 395 may be associated with the passphrase PASSWORD. 396 397 VERIFY can be specified either as NIL if no check should be performed, 398 :OPTIONAL to verify the server's certificate if it presented one or 399 :REQUIRED to verify the server's certificate and fail if an invalid 400 or no certificate was presented. 401 402 HOSTNAME if specified, will be sent by client during TLS negotiation, 403 according to the Server Name Indication (SNI) extension to the TLS. 404 When server handles several domain names, this extension enables the server 405 to choose certificate for right domain. Also the HOSTNAME is used for 406 hostname verification if verification is enabled by VERIFY." 407 (ensure-initialized :method method) 408 (let ((stream (make-instance 'ssl-stream 409 :socket socket 410 :close-callback close-callback))) 411 (with-new-ssl (handle) 412 (if hostname 413 (cffi:with-foreign-string (chostname hostname) 414 (ssl-set-tlsext-host-name handle chostname))) 415 (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p)) 416 (ssl-set-connect-state handle) 417 (when (zerop (ssl-set-cipher-list handle cipher-list)) 418 (error 'ssl-error-initialize :reason "Can't set SSL cipher list")) 419 (with-pem-password (password) 420 (install-key-and-cert handle key certificate)) 421 (ensure-ssl-funcall stream handle #'ssl-connect handle) 422 (maybe-verify-client-stream stream verify hostname) 423 (handle-external-format stream external-format)))) 424 425 ;; fixme: free the context when errors happen in this function 426 (defun make-ssl-server-stream 427 (socket &key certificate key password method external-format 428 close-callback (unwrap-stream-p t) 429 (cipher-list *default-cipher-list*)) 430 "Returns an SSL stream for the server socket descriptor SOCKET. 431 CERTIFICATE is the path to a file containing the PEM-encoded certificate for 432 your server. KEY is the path to the PEM-encoded key for the server, which 433 may be associated with the passphrase PASSWORD." 434 (ensure-initialized :method method) 435 (let ((stream (make-instance 'ssl-server-stream 436 :socket socket 437 :close-callback close-callback 438 :certificate certificate 439 :key key))) 440 (with-new-ssl (handle) 441 (setf socket (install-handle-and-bio stream handle socket unwrap-stream-p)) 442 (ssl-set-accept-state handle) 443 (when (zerop (ssl-set-cipher-list handle cipher-list)) 444 (error 'ssl-error-initialize :reason "Can't set SSL cipher list")) 445 (with-pem-password (password) 446 (install-key-and-cert handle key certificate)) 447 (ensure-ssl-funcall stream handle #'ssl-accept handle) 448 (handle-external-format stream external-format)))) 449 450 #+openmcl 451 (defmethod stream-deadline ((stream ccl::basic-stream)) 452 (ccl::ioblock-deadline (ccl::stream-ioblock stream t))) 453 #+openmcl 454 (defmethod stream-deadline ((stream t)) 455 nil) 456 457 458 (defgeneric stream-fd (stream)) 459 (defmethod stream-fd (stream) stream) 460 461 #+sbcl 462 (defmethod stream-fd ((stream sb-sys:fd-stream)) 463 (sb-sys:fd-stream-fd stream)) 464 465 #+cmu 466 (defmethod stream-fd ((stream system:fd-stream)) 467 (system:fd-stream-fd stream)) 468 469 #+openmcl 470 (defmethod stream-fd ((stream ccl::basic-stream)) 471 (ccl::ioblock-device (ccl::stream-ioblock stream t))) 472 473 #+clisp 474 (defmethod stream-fd ((stream stream)) 475 ;; sockets appear to be direct instances of STREAM 476 (ext:stream-handles stream)) 477 478 #+ecl 479 (defmethod stream-fd ((stream two-way-stream)) 480 (si:file-stream-fd (two-way-stream-input-stream stream))) 481 482 #+allegro 483 (defmethod stream-fd ((stream stream)) 484 (socket:socket-os-fd stream)) 485 486 #+lispworks 487 (defmethod stream-fd ((stream comm::socket-stream)) 488 (comm:socket-stream-socket stream))