source: project/release/5/openssl/trunk/tests/socket-test.scm @ 40256

Last change on this file since 40256 was 40256, checked in by Vasilij Schneidermann, 3 months ago

openssl: Add socket tests

File size: 4.2 KB
Line 
1(define ssl-port (make-parameter #f))
2(define openssl (make-parameter #f))
3(define csr-config-path (make-parameter #f))
4(define private-key-path (make-parameter #f))
5(define public-key-path (make-parameter #f))
6
7(define (clean-up! path)
8  (when path
9    (delete-file* path)))
10
11(on-exit
12 (lambda ()
13   (clean-up! (csr-config-path))
14   (clean-up! (private-key-path))
15   (clean-up! (public-key-path))))
16
17(define (getenv key #!optional default)
18  (or (get-environment-variable key) default))
19
20;;https://gitlab.com/ariSun/myriam/-/blob/54e826226e26ac8a243f6be471bb164cf9d971e4/src/myriam.address.scm#L11-15
21(define (unused-port)
22  (let* ((listener (tcp-listen 0))
23         (port (tcp-listener-port listener)))
24    (tcp-close listener)
25    port))
26
27(define (create-keys!)
28  (call-with-output-file (csr-config-path)
29    (lambda (out)
30      (display "[dn]
31CN=localhost
32[req]
33distinguished_name = dn
34[EXT]
35subjectAltName=DNS:localhost
36keyUsage=digitalSignature
37extendedKeyUsage=serverAuth" out)))
38  (system* (format "~a req -x509 -out ~a -keyout ~a -newkey rsa:2048 -nodes -sha256 -subj \"/CN=localhost\" -extensions EXT -config ~a"
39                   (qs (openssl))
40                   (qs (public-key-path))
41                   (qs (private-key-path))
42                   (qs (csr-config-path)))))
43
44(define (start-server protocol)
45  (parameterize ((server-port (ssl-port)))
46    (let ((listener (ssl-listen* port: (ssl-port)
47                                 protocol: protocol
48                                 certificate: (public-key-path)
49                                 private-key: (private-key-path))))
50      (accept-loop listener ssl-accept))))
51
52(define (start-client protocol)
53  (define (make-http-server-connector)
54    (lambda (uri proxy)
55      (let ((remote-end (or proxy uri)))
56        (case (uri-scheme remote-end)
57          ((#f http) (tcp-connect (uri-host remote-end) (uri-port remote-end)))
58          ((https) (receive (in out)
59                       (ssl-connect* hostname: (uri-host remote-end)
60                                     port: (uri-port remote-end)
61                                     protocol: protocol
62                                     sni-name: #t
63                                     verify?: #f)
64                     (if (and in out) ; Ugly, but necessary
65                         (values in out)
66                         (error "You forgot to install the openssl egg."))))
67          (else (error "This shouldn't happen"))))))
68  (parameterize ((server-connector (make-http-server-connector)))
69    (let ((url (format "https://localhost:~a" (ssl-port))))
70      (with-input-from-request url #f read-string))))
71
72(openssl (or (getenv "OPENSSL_BINARY" "openssl")))
73(csr-config-path (create-temporary-file ".conf"))
74(private-key-path (create-temporary-file ".key"))
75(public-key-path (create-temporary-file ".pem"))
76
77(vhost-map `((".*" . ,(lambda (continue)
78                       (send-response status: 'ok body: "")))))
79(create-keys!)
80
81(define-syntax protocol-test
82  (syntax-rules ()
83    ((_ tester client-protocol server-protocol)
84     (let ((random-port (unused-port))
85           (label (format "~a -> ~a" client-protocol server-protocol)))
86       (parameterize ((ssl-port random-port)
87                      (test-server-port random-port))
88         (with-test-server
89          (lambda ()
90            (start-server server-protocol))
91          (lambda ()
92            (tester label (start-client client-protocol)))))))))
93
94(define (compatible-protocol-test client-protocol server-protocol)
95  (protocol-test test-assert client-protocol server-protocol))
96
97(define (incompatible-protocol-test client-protocol server-protocol)
98  (protocol-test test-error client-protocol server-protocol))
99
100(compatible-protocol-test 'tlsv1 'tlsv1)
101(compatible-protocol-test 'tlsv12 'tlsv12)
102(compatible-protocol-test 'tlsv1 '(tlsv1 . tlsv12))
103(compatible-protocol-test 'tlsv12 '(tlsv1 . tlsv12))
104(compatible-protocol-test '(tlsv1 . tlsv12) 'tlsv11)
105(compatible-protocol-test '(tlsv11 . tlsv12) 'tlsv12)
106(compatible-protocol-test '(tlsv1 . tlsv12) '(tlsv1 . tlsv12))
107(compatible-protocol-test '(tlsv1 . tlsv12) '(tlsv11 . tlsv12))
108(incompatible-protocol-test 'tlsv1 'tlsv12)
109(incompatible-protocol-test 'tlsv12 'tlsv1)
110(incompatible-protocol-test 'tlsv1 '(tlsv11 . tlsv12))
111(incompatible-protocol-test '(tlsv11 . tlsv12) 'tlsv1)
Note: See TracBrowser for help on using the repository browser.