Ticket #1557: openssl-default-certs.diff.txt

File openssl-default-certs.diff.txt, 5.0 KB (added by Jim Ursetto, 3 years ago)
Line 
1Index: 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))))