3rdparties/software/cl+ssl-20200427-git/src/context.lisp (6025 bytes)
1 ;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*- 2 3 (in-package :cl+ssl) 4 5 (define-condition verify-location-not-found-error (ssl-error) 6 ((location :initarg :location)) 7 (:documentation "Unable to find verify locations") 8 (:report (lambda (condition stream) 9 (format stream "Unable to find verify location. Path: ~A" (slot-value condition 'location))))) 10 11 (defun validate-verify-location (location) 12 (handler-case 13 (cond 14 ((uiop:file-exists-p location) 15 (values location t)) 16 ((uiop:directory-exists-p location) 17 (values location nil)) 18 (t 19 (error 'verify-location-not-found-error :location location))))) 20 21 (defun add-verify-locations (ctx locations) 22 (dolist (location locations) 23 (multiple-value-bind (location isfile) 24 (validate-verify-location location) 25 (cffi:with-foreign-strings ((location-ptr location)) 26 (unless (= 1 (cl+ssl::ssl-ctx-load-verify-locations 27 ctx 28 (if isfile location-ptr (cffi:null-pointer)) 29 (if isfile (cffi:null-pointer) location-ptr))) 30 (error 'ssl-error :queue (read-ssl-error-queue) :message (format nil "Unable to load verify location ~A" location))))))) 31 32 (defun ssl-ctx-set-verify-location (ctx location) 33 (cond 34 ((eq :default location) 35 (unless (= 1 (ssl-ctx-set-default-verify-paths ctx)) 36 (error 'ssl-error-call 37 :queue (read-ssl-error-queue) 38 :message (format nil "Unable to load default verify paths")))) 39 ((eq :default-file location) 40 ;; supported since openssl 1.1.0 41 (unless (= 1 (ssl-ctx-set-default-verify-file ctx)) 42 (error 'ssl-error-call 43 :queue (read-ssl-error-queue) 44 :message (format nil "Unable to load default verify file")))) 45 ((eq :default-dir location) 46 ;; supported since openssl 1.1.0 47 (unless (= 1 (ssl-ctx-set-default-verify-dir ctx)) 48 (error 'ssl-error-call 49 :queue (read-ssl-error-queue) 50 :message (format nil "Unable to load default verify dir")))) 51 ((stringp location) 52 (add-verify-locations ctx (list location))) 53 ((pathnamep location) 54 (add-verify-locations ctx (list location))) 55 ((and location (listp location)) 56 (add-verify-locations ctx location)) 57 ;; silently allow NIL as location 58 (location 59 (error "Invalid location ~a" location)))) 60 61 (alexandria:define-constant +default-cipher-list+ 62 (format nil 63 "ECDHE-RSA-AES256-GCM-SHA384:~ 64 ECDHE-RSA-AES256-SHA384:~ 65 ECDHE-RSA-AES256-SHA:~ 66 ECDHE-RSA-AES128-GCM-SHA256:~ 67 ECDHE-RSA-AES128-SHA256:~ 68 ECDHE-RSA-AES128-SHA:~ 69 ECDHE-RSA-RC4-SHA:~ 70 DHE-RSA-AES256-GCM-SHA384:~ 71 DHE-RSA-AES256-SHA256:~ 72 DHE-RSA-AES256-SHA:~ 73 DHE-RSA-AES128-GCM-SHA256:~ 74 DHE-RSA-AES128-SHA256:~ 75 DHE-RSA-AES128-SHA:~ 76 AES256-GCM-SHA384:~ 77 AES256-SHA256:~ 78 AES256-SHA:~ 79 AES128-GCM-SHA256:~ 80 AES128-SHA256:~ 81 AES128-SHA") :test 'equal) 82 83 (cffi:defcallback verify-peer-callback :int ((ok :int) (ctx :pointer)) 84 (let ((error-code (x509-store-ctx-get-error ctx))) 85 (unless (= error-code 0) 86 (error 'ssl-error-verify :error-code error-code)) 87 ok)) 88 89 (defun make-context (&key (method nil method-supplied-p) 90 (disabled-protocols) 91 (options (list +SSL-OP-ALL+)) 92 (session-cache-mode +ssl-sess-cache-server+) 93 (verify-location :default) 94 (verify-depth 100) 95 (verify-mode +ssl-verify-peer+) 96 (verify-callback nil verify-callback-supplied-p) 97 (cipher-list +default-cipher-list+) 98 (pem-password-callback 'pem-password-callback)) 99 (ensure-initialized) 100 (let ((ctx (ssl-ctx-new (if method-supplied-p 101 method 102 (progn 103 (unless disabled-protocols 104 (setf disabled-protocols 105 (list +SSL-OP-NO-SSLv2+ +SSL-OP-NO-SSLv3+))) 106 (funcall (default-ssl-method))))))) 107 (when (cffi:null-pointer-p ctx) 108 (error 'ssl-error-initialize :reason "Can't create new SSL CTX" :queue (read-ssl-error-queue))) 109 (handler-bind ((error (lambda (_) 110 (declare (ignore _)) 111 (ssl-ctx-free ctx)))) 112 (ssl-ctx-set-options ctx (apply #'logior (append disabled-protocols options))) 113 (ssl-ctx-set-session-cache-mode ctx session-cache-mode) 114 (ssl-ctx-set-verify-location ctx verify-location) 115 (ssl-ctx-set-verify-depth ctx verify-depth) 116 (ssl-ctx-set-verify ctx verify-mode (if verify-callback 117 (cffi:get-callback verify-callback) 118 (if verify-callback-supplied-p 119 (cffi:null-pointer) 120 (if (= verify-mode +ssl-verify-peer+) 121 (cffi:callback verify-peer-callback) 122 (cffi:null-pointer))))) 123 (ssl-ctx-set-cipher-list ctx cipher-list) 124 (ssl-ctx-set-default-passwd-cb ctx (cffi:get-callback pem-password-callback)) 125 ctx))) 126 127 (defun call-with-global-context (context auto-free-p body-fn) 128 (let* ((*ssl-global-context* context)) 129 (unwind-protect (funcall body-fn) 130 (when auto-free-p 131 (ssl-ctx-free context))))) 132 133 (defmacro with-global-context ((context &key auto-free-p) &body body) 134 `(call-with-global-context ,context ,auto-free-p (lambda () ,@body)))