| 1 | Index: openssl.scm
|
|---|
| 2 | ===================================================================
|
|---|
| 3 | --- openssl.scm (revision 36801)
|
|---|
| 4 | +++ openssl.scm (working copy)
|
|---|
| 5 | @@ -24,6 +24,8 @@
|
|---|
| 6 | ssl-load-private-key!
|
|---|
| 7 | ssl-set-verify!
|
|---|
| 8 | ssl-load-verify-root-certificates!
|
|---|
| 9 | + ssl-load-default-root-certificates!
|
|---|
| 10 | + ssl-load-default-root-certificates?
|
|---|
| 11 | ssl-load-suggested-certificate-authorities!
|
|---|
| 12 | ssl-peer-verified?
|
|---|
| 13 | ssl-peer-subject-name ssl-peer-issuer-name
|
|---|
| 14 | @@ -775,6 +777,16 @@
|
|---|
| 15 | " : SSL_VERIFY_NONE), NULL);\n")
|
|---|
| 16 | (ssl-unwrap-context obj) v))
|
|---|
| 17 |
|
|---|
| 18 | +;; load system default root certificates into SSL context
|
|---|
| 19 | +(define (ssl-load-default-root-certificates! obj)
|
|---|
| 20 | + (ssl-clear-error)
|
|---|
| 21 | + (unless (eq?
|
|---|
| 22 | + ((foreign-lambda
|
|---|
| 23 | + int "SSL_CTX_set_default_verify_paths" c-pointer)
|
|---|
| 24 | + (ssl-unwrap-context obj))
|
|---|
| 25 | + 1)
|
|---|
| 26 | + (ssl-abort 'ssl-set-default-verify-paths! #f)))
|
|---|
| 27 | +
|
|---|
| 28 | ;; load trusted root certificates into SSL context
|
|---|
| 29 | (define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname #f))
|
|---|
| 30 | (if pathname (##sys#check-string pathname))
|
|---|
| 31 | @@ -843,21 +855,23 @@
|
|---|
| 32 |
|
|---|
| 33 | ;;; wrappers with secure defaults
|
|---|
| 34 |
|
|---|
| 35 | +;; deprecated; unused
|
|---|
| 36 | (define ssl-default-certificate-authority-directory
|
|---|
| 37 | - (make-parameter
|
|---|
| 38 | - (cond-expand
|
|---|
| 39 | - (unix "/etc/ssl/certs")
|
|---|
| 40 | - (else "certs"))))
|
|---|
| 41 | + (make-parameter #f))
|
|---|
| 42 |
|
|---|
| 43 | +(define ssl-load-default-root-certificates?
|
|---|
| 44 | + (make-parameter #t))
|
|---|
| 45 | +
|
|---|
| 46 | (define (ssl-make-client-context* #!key (protocol 'tlsv12) (cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1? certificate-authorities certificate-authority-directory (verify? #t))
|
|---|
| 47 | - (unless (or certificate-authorities certificate-authority-directory)
|
|---|
| 48 | - (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
|
|---|
| 49 | (let ((ctx (ssl-make-client-context protocol)))
|
|---|
| 50 | (ssl-set-cipher-list! ctx cipher-list)
|
|---|
| 51 | (when certificate
|
|---|
| 52 | (ssl-load-certificate-chain! ctx certificate)
|
|---|
| 53 | (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?))
|
|---|
| 54 | - (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)
|
|---|
| 55 | + (when ssl-load-default-root-certificates?
|
|---|
| 56 | + (ssl-load-default-root-certificates! ctx))
|
|---|
| 57 | + (when (or certificate-authorities certificate-authority-directory)
|
|---|
| 58 | + (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory))
|
|---|
| 59 | (ssl-set-verify! ctx verify?)
|
|---|
| 60 | ctx))
|
|---|
| 61 |
|
|---|
| 62 | @@ -865,8 +879,6 @@
|
|---|
| 63 | (ssl-connect hostname port (apply ssl-make-client-context* args) sni-name))
|
|---|
| 64 |
|
|---|
| 65 | (define (ssl-listen* #!key hostname (port 0) (backlog 4) (protocol 'tlsv12) (cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1? certificate-authorities certificate-authority-directory (verify? #f))
|
|---|
| 66 | - (unless (or certificate-authorities certificate-authority-directory)
|
|---|
| 67 | - (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
|
|---|
| 68 | (let ((ear (ssl-listen port backlog hostname protocol)))
|
|---|
| 69 | (ssl-set-cipher-list! ear cipher-list)
|
|---|
| 70 | (ssl-load-certificate-chain! ear certificate)
|
|---|
| 71 | @@ -873,13 +885,14 @@
|
|---|
| 72 | (ssl-load-private-key! ear private-key private-key-type private-key-asn1?)
|
|---|
| 73 | (when certificate-authorities
|
|---|
| 74 | (ssl-load-suggested-certificate-authorities! ear certificate-authorities))
|
|---|
| 75 | - (ssl-load-verify-root-certificates! ear certificate-authorities certificate-authority-directory)
|
|---|
| 76 | + (when ssl-load-default-root-certificates?
|
|---|
| 77 | + (ssl-load-default-root-certificates! ear))
|
|---|
| 78 | + (when (or certificate-authorities certificate-authority-directory)
|
|---|
| 79 | + (ssl-load-verify-root-certificates! ear certificate-authorities certificate-authority-directory))
|
|---|
| 80 | (ssl-set-verify! ear verify?)
|
|---|
| 81 | ear))
|
|---|
| 82 |
|
|---|
| 83 | (define (ssl-start* server? tcp-in tcp-out #!key (protocol 'tlsv12) (cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1? certificate-authorities certificate-authority-directory (verify? (not server?)) sni-name)
|
|---|
| 84 | - (unless (or certificate-authorities certificate-authority-directory)
|
|---|
| 85 | - (set! certificate-authority-directory (ssl-default-certificate-authority-directory)))
|
|---|
| 86 | ;; ssl-wrap-client-context only serves a technical purpose here,
|
|---|
| 87 | ;; as the plain context pointer needs to be wrapped somehow.
|
|---|
| 88 | (let ((ctx (ssl-wrap-client-context (ssl-ctx-new protocol server?))))
|
|---|
| 89 | @@ -889,7 +902,10 @@
|
|---|
| 90 | (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?))
|
|---|
| 91 | (when certificate-authorities
|
|---|
| 92 | (ssl-load-suggested-certificate-authorities! ctx certificate-authorities))
|
|---|
| 93 | - (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)
|
|---|
| 94 | + (when ssl-load-default-root-certificates?
|
|---|
| 95 | + (ssl-load-default-root-certificates! ctx))
|
|---|
| 96 | + (when (or certificate-authorities certificate-authority-directory)
|
|---|
| 97 | + (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory))
|
|---|
| 98 | (ssl-set-verify! ctx verify?)
|
|---|
| 99 | (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
|
|---|
| 100 | (ssl (ssl-new (ssl-unwrap-client-context ctx))))
|
|---|
