| 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)))) |
|---|
