Index: openssl.scm =================================================================== --- openssl.scm (revision 36801) +++ openssl.scm (working copy) @@ -24,6 +24,8 @@ ssl-load-private-key! ssl-set-verify! ssl-load-verify-root-certificates! + ssl-load-default-root-certificates! + ssl-load-default-root-certificates? ssl-load-suggested-certificate-authorities! ssl-peer-verified? ssl-peer-subject-name ssl-peer-issuer-name @@ -775,6 +777,16 @@ " : SSL_VERIFY_NONE), NULL);\n") (ssl-unwrap-context obj) v)) +;; load system default root certificates into SSL context +(define (ssl-load-default-root-certificates! obj) + (ssl-clear-error) + (unless (eq? + ((foreign-lambda + int "SSL_CTX_set_default_verify_paths" c-pointer) + (ssl-unwrap-context obj)) + 1) + (ssl-abort 'ssl-set-default-verify-paths! #f))) + ;; load trusted root certificates into SSL context (define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname #f)) (if pathname (##sys#check-string pathname)) @@ -843,21 +855,23 @@ ;;; wrappers with secure defaults +;; deprecated; unused (define ssl-default-certificate-authority-directory - (make-parameter - (cond-expand - (unix "/etc/ssl/certs") - (else "certs")))) + (make-parameter #f)) +(define ssl-load-default-root-certificates? + (make-parameter #t)) + (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)) - (unless (or certificate-authorities certificate-authority-directory) - (set! certificate-authority-directory (ssl-default-certificate-authority-directory))) (let ((ctx (ssl-make-client-context protocol))) (ssl-set-cipher-list! ctx cipher-list) (when certificate (ssl-load-certificate-chain! ctx certificate) (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?)) - (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory) + (when ssl-load-default-root-certificates? + (ssl-load-default-root-certificates! ctx)) + (when (or certificate-authorities certificate-authority-directory) + (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)) (ssl-set-verify! ctx verify?) ctx)) @@ -865,8 +879,6 @@ (ssl-connect hostname port (apply ssl-make-client-context* args) sni-name)) (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)) - (unless (or certificate-authorities certificate-authority-directory) - (set! certificate-authority-directory (ssl-default-certificate-authority-directory))) (let ((ear (ssl-listen port backlog hostname protocol))) (ssl-set-cipher-list! ear cipher-list) (ssl-load-certificate-chain! ear certificate) @@ -873,13 +885,14 @@ (ssl-load-private-key! ear private-key private-key-type private-key-asn1?) (when certificate-authorities (ssl-load-suggested-certificate-authorities! ear certificate-authorities)) - (ssl-load-verify-root-certificates! ear certificate-authorities certificate-authority-directory) + (when ssl-load-default-root-certificates? + (ssl-load-default-root-certificates! ear)) + (when (or certificate-authorities certificate-authority-directory) + (ssl-load-verify-root-certificates! ear certificate-authorities certificate-authority-directory)) (ssl-set-verify! ear verify?) ear)) (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) - (unless (or certificate-authorities certificate-authority-directory) - (set! certificate-authority-directory (ssl-default-certificate-authority-directory))) ;; ssl-wrap-client-context only serves a technical purpose here, ;; as the plain context pointer needs to be wrapped somehow. (let ((ctx (ssl-wrap-client-context (ssl-ctx-new protocol server?)))) @@ -889,7 +902,10 @@ (ssl-load-private-key! ctx private-key private-key-type private-key-asn1?)) (when certificate-authorities (ssl-load-suggested-certificate-authorities! ctx certificate-authorities)) - (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory) + (when ssl-load-default-root-certificates? + (ssl-load-default-root-certificates! ctx)) + (when (or certificate-authorities certificate-authority-directory) + (ssl-load-verify-root-certificates! ctx certificate-authorities certificate-authority-directory)) (ssl-set-verify! ctx verify?) (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out)) (ssl (ssl-new (ssl-unwrap-client-context ctx))))