1032ce8afe
Using the functions on a port triggers renegotiation of the connection, which s useful for cases such as a web server that requires a certificate only for certain paths. This functionality also allows better testing of the SSL library.
127 lines
5.0 KiB
Racket
127 lines
5.0 KiB
Racket
#lang racket
|
|
|
|
(require openssl
|
|
ffi/unsafe
|
|
racket/tcp
|
|
racket/runtime-path)
|
|
|
|
(define (check fmt got expect)
|
|
(unless (equal? got expect)
|
|
(error 'check fmt got)))
|
|
|
|
(define-runtime-path server-key "server_key.pem")
|
|
(define-runtime-path server-crt "server_crt.pem")
|
|
(define-runtime-path client-key "client_key.pem")
|
|
(define-runtime-path client-crt "client_crt.pem")
|
|
(define-runtime-path cacert "cacert.pem")
|
|
|
|
(define (go valid?
|
|
#:later [later-mode #f]
|
|
#:early [early-mode (and (not later-mode) 'try)]
|
|
#:accept-fail? [accept-fail? #f]
|
|
#:verify-fail? [verify-fail? #f])
|
|
(define ssl-server-context (ssl-make-server-context 'sslv3))
|
|
|
|
(ssl-load-private-key! ssl-server-context server-key)
|
|
(ssl-load-certificate-chain! ssl-server-context server-crt)
|
|
(ssl-load-verify-root-certificates! ssl-server-context cacert)
|
|
(when early-mode
|
|
((if (eq? early-mode 'try) ssl-try-verify! ssl-set-verify!)
|
|
ssl-server-context
|
|
#t))
|
|
|
|
(define ssl-listener (ssl-listen 55000
|
|
4
|
|
#t
|
|
"127.0.0.1"
|
|
ssl-server-context))
|
|
|
|
(define listener-main
|
|
(thread
|
|
(lambda()
|
|
(with-handlers ([(lambda (x) (and accept-fail?
|
|
(exn? x)
|
|
(regexp-match? #rx"accept failed" (exn-message x))))
|
|
(lambda (x) (ssl-close ssl-listener))]
|
|
[(lambda (x) (and verify-fail? (eq? x 'escape)))
|
|
(lambda (x) (void))])
|
|
(let-values ([(in out) (ssl-accept ssl-listener)])
|
|
(check "Server: Accepted connection.~n" #t #t)
|
|
(when later-mode
|
|
(check "Server: From Client: ~a~n" (read-line in) "we're started")
|
|
(with-handlers ([(lambda (x) (and verify-fail?
|
|
(exn? x)
|
|
(regexp-match? #rx"ssl-set-verify!: failed" (exn-message x))))
|
|
(lambda (x)
|
|
(ssl-close ssl-listener)
|
|
(raise 'escape))])
|
|
((if (eq? later-mode 'try) ssl-try-verify! ssl-set-verify!) in #t))
|
|
(write-string "still going\n" out)
|
|
(flush-output out))
|
|
(check "Server: Verified ~v~n" (ssl-peer-verified? in) valid?)
|
|
(check "Server: Verified ~v~n" (ssl-peer-verified? out) valid?)
|
|
(check "Server: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in)
|
|
(and valid?
|
|
#"/CN=testclient.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT"))
|
|
(check "Server: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in)
|
|
(and valid?
|
|
#"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department"))
|
|
(ssl-close ssl-listener)
|
|
(check "Server: From Client: ~a~n" (read-line in) "yay the connection was made")
|
|
(close-input-port in)
|
|
(close-output-port out))))))
|
|
|
|
|
|
(define ssl-client-context (ssl-make-client-context 'sslv3))
|
|
|
|
(ssl-load-private-key! ssl-client-context client-key)
|
|
|
|
;;connection will still proceed if these methods aren't called
|
|
;;change to #f to try it
|
|
(when valid?
|
|
(ssl-load-certificate-chain! ssl-client-context client-crt)
|
|
(ssl-load-verify-root-certificates! ssl-client-context cacert)
|
|
(ssl-set-verify! ssl-client-context #t))
|
|
|
|
|
|
(let-values ([(in out) (ssl-connect "127.0.0.1"
|
|
55000
|
|
ssl-client-context)])
|
|
(check "Client: Made connection.~n" #t #t)
|
|
(when later-mode
|
|
(write-string "we're started\n" out)
|
|
(flush-output out)
|
|
(unless verify-fail?
|
|
(check "Client: From Server: ~a~n" (read-line in) "still going")))
|
|
(check "Client: Verified ~v~n" (ssl-peer-verified? in) valid?)
|
|
(check "Client: Verified ~v~n" (ssl-peer-verified? out) valid?)
|
|
(check "Client: Verified Peer Subject Name ~v~n" (ssl-peer-subject-name in)
|
|
#"/CN=test.okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT")
|
|
(check "Client: Verified Peer Issuer Name ~v~n" (ssl-peer-issuer-name in)
|
|
#"/CN=okcomps.com/ST=OH/C=US/emailAddress=root@okcomps.com/O=OK Computers LLC/OU=IT Department")
|
|
|
|
(write-string (format "yay the connection was made~n") out)
|
|
(close-input-port in)
|
|
(close-output-port out))
|
|
|
|
(thread-wait listener-main))
|
|
|
|
(go #t)
|
|
(go #t #:early 'req)
|
|
(go #f)
|
|
(go #t #:later 'try)
|
|
(go #f #:later 'try)
|
|
(go #t #:later 'req)
|
|
|
|
(define (check-fail thunk)
|
|
(define s
|
|
(with-handlers ([exn? (lambda (exn) (exn-message exn))])
|
|
(thunk)
|
|
"success"))
|
|
(unless (regexp-match? #rx"connect failed" s)
|
|
(error 'test "failed: ~s" s)))
|
|
|
|
(check-fail (lambda () (go #f #:early 'req #:accept-fail? #t)))
|
|
(go #f #:later 'req #:verify-fail? #t)
|
|
|