suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

openssl: add supported-{client,server}-protocols

Browse Source 
Use the new functions to avoid running a test that requires 'tls12
to succeed.
This commit is contained in:
Matthew Flatt 2014-07-16 12:52:43 +01:00
parent 70c2f72166
commit d7f2c869b6
3 changed files with 115 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
pkgs/racket-pkgs/racket-doc/openssl/openssl.scrbl
View File

@ -62,13 +62,8 @@ using the functions described in @secref["cert-procs"].
@defproc[(ssl-connect [hostname string?] @defproc[(ssl-connect [hostname string?]
[port-no (integer-in 1 65535)] [port-no (integer-in 1 65535)]
[client-protocol [client-protocol
(or/c ssl-client-context? (or/c ssl-client-context?
'sslv2-or-v3 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12)
'sslv2
'sslv3
'tls
'tls11
'tls12)
'sslv2-or-v3]) 'sslv2-or-v3])
(values input-port? output-port?)]{ (values input-port? output-port?)]{
@ -177,14 +172,26 @@ The @racket[protocol] must be one of the following:
Note that SSL protocol version 2 is deprecated on some platforms and may not be Note that SSL protocol version 2 is deprecated on some platforms and may not be
present in your system libraries. The use of SSLv2 may also compromise security; present in your system libraries. The use of SSLv2 may also compromise security;
thus, using SSLv3 is recommended. thus, using SSLv3 is recommended. TLS 1.1 and 1.2 are relatively new and not
} always available. See also @racket[supported-client-protocols] and
@racket[supported-server-protocols].
@history[#:changed "6.1" @elem{Added @racket['tls11] and @racket['tls12].}]}
@defproc[(supported-client-protocols)
(listof (or/c 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12))]{
Returns a list of symbols representing protocols that are supported
for clients on the current platform.}
@defproc[(ssl-client-context? [v any/c]) boolean?]{ @defproc[(ssl-client-context? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a value produced by Returns @racket[#t] if @racket[v] is a value produced by
@racket[ssl-make-client-context], @racket[#f] otherwise.} @racket[ssl-make-client-context], @racket[#f] otherwise.
@history[#:added "6.0.1.3"]}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@ -269,11 +276,19 @@ Returns @racket[#t] of @racket[v] is an SSL port produced by
Like @racket[ssl-make-client-context], but creates a server context.} Like @racket[ssl-make-client-context], but creates a server context.}
@defproc[(ssl-server-context? [v any/c]) boolean?]{ @defproc[(ssl-server-context? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a value produced by Returns @racket[#t] if @racket[v] is a value produced by
@racket[ssl-make-server-context], @racket[#f] otherwise.} @racket[ssl-make-server-context], @racket[#f] otherwise.}
@defproc[(supported-server-protocols)
(listof (or/c 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12))]{
Returns a list of symbols representing protocols that are supported
for servers on the current platform.
@history[#:added "6.0.1.3"]}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------

51
pkgs/racket-pkgs/racket-test/tests/openssl/test-ephemeral.rkt
View File

@ -8,7 +8,7 @@
(define (test-ephemeral server-enable! client-ciphers) (define (test-ephemeral server-enable! client-ciphers)
(let-values ([(r1 w2) (make-pipe 10)] (let-values ([(r1 w2) (make-pipe 10)]
[(r2 w1) (make-pipe 10)]) [(r2 w1) (make-pipe 10)])
(define server-thread (define server-thread
(thread (lambda () (thread (lambda ()
(define server-ctx (ssl-make-server-context 'tls12)) (define server-ctx (ssl-make-server-context 'tls12))
@ -43,28 +43,33 @@
(thread-wait server-thread) (thread-wait server-thread)
(void))) (void)))
;; Test DHE ciphers (note: cipher spec is "EDH", contrary to openssl ciphers docs) (cond
(test-ephemeral (lambda (server-ctx) [(memq 'tls12 (supported-server-protocols))
(ssl-server-context-enable-dhe! server-ctx ssl-dh4096-param-path)) ;; Test DHE ciphers (note: cipher spec is "EDH", contrary to openssl ciphers docs)
"AES+EDH") (test-ephemeral (lambda (server-ctx)
(ssl-server-context-enable-dhe! server-ctx ssl-dh4096-param-path))
"AES+EDH")
;; Test ECDHE ciphers ;; Test ECDHE ciphers
(test-ephemeral (lambda (server-ctx) (test-ephemeral (lambda (server-ctx)
(ssl-server-context-enable-ecdhe! server-ctx 'secp192k1)) (ssl-server-context-enable-ecdhe! server-ctx 'secp192k1))
"ECDHE-RSA-AES128-SHA256") "ECDHE-RSA-AES128-SHA256")
;; Sanity check for DHE: connection fails when enable! not called ;; Sanity check for DHE: connection fails when enable! not called
(check-exn (check-exn
#rx"connect failed" #rx"connect failed"
(lambda () (lambda ()
;; for DrDr, suppress accept error printing ;; for DrDr, suppress accept error printing
(parameterize ((current-error-port (open-output-string))) (parameterize ((current-error-port (open-output-string)))
(test-ephemeral void "AES+EDH")))) (test-ephemeral void "AES+EDH"))))
;; Sanity check for ECDHE: connection fails when enable! not called
(check-exn
#rx"connect failed"
(lambda ()
;; for DrDr, suppress accept error printing
(parameterize ((current-error-port (open-output-string)))
(test-ephemeral void "ECDHE-RSA-AES128-SHA256"))))]
[else
(printf "TLS 1.2 not supported; skipping tests\n")])
;; Sanity check for ECDHE: connection fails when enable! not called
(check-exn
#rx"connect failed"
(lambda ()
;; for DrDr, suppress accept error printing
(parameterize ((current-error-port (open-output-string)))
(test-ephemeral void "ECDHE-RSA-AES128-SHA256"))))

90
racket/collects/openssl/mzssl.rkt
View File

@ -190,7 +190,9 @@ TO DO:
[ssl-abandon-port [ssl-abandon-port
(c-> ssl-port? void?)] (c-> ssl-port? void?)]
[ssl-port? [ssl-port?
(c-> any/c boolean?)])) (c-> any/c boolean?)])
supported-client-protocols
supported-server-protocols)
(define ssl-load-fail-reason (define ssl-load-fail-reason
(or libssl-load-fail-reason (or libssl-load-fail-reason
@ -223,18 +225,18 @@ TO DO:
(define-cpointer-type _EC_KEY*) (define-cpointer-type _EC_KEY*)
(define-cstruct _GENERAL_NAME ([type _int] [d _ASN1_STRING*])) (define-cstruct _GENERAL_NAME ([type _int] [d _ASN1_STRING*]))
(define-ssl SSLv2_client_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv2_client_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl SSLv2_server_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv2_server_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl SSLv3_client_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv3_client_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl SSLv3_server_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv3_server_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl SSLv23_client_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv23_client_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl SSLv23_server_method (_fun -> _SSL_METHOD*)) (define-ssl SSLv23_server_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl TLSv1_client_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_client_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl TLSv1_server_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_server_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl TLSv1_1_client_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_1_client_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl TLSv1_1_server_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_1_server_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl TLSv1_2_client_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_2_client_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-ssl TLSv1_2_server_method (_fun -> _SSL_METHOD*)) (define-ssl TLSv1_2_server_method (_fun -> _SSL_METHOD*) #:fail (lambda () #f))
(define-crypto DH_free (_fun _DH* -> _void) #:wrap (deallocator)) (define-crypto DH_free (_fun _DH* -> _void) #:wrap (deallocator))
(define-crypto EC_KEY_free (_fun _EC_KEY* -> _void) #:wrap (deallocator)) (define-crypto EC_KEY_free (_fun _EC_KEY* -> _void) #:wrap (deallocator))
@ -518,21 +520,53 @@ TO DO:
(define default-encrypt 'sslv2-or-v3) (define default-encrypt 'sslv2-or-v3)
(define (encrypt->method who e client?) (define (encrypt->method who e client?)
((case e (define f
[(sslv2-or-v3) (case e
(if client? SSLv23_client_method SSLv23_server_method)] [(sslv2-or-v3)
[(sslv2) (if client? SSLv23_client_method SSLv23_server_method)]
(if client? SSLv2_client_method SSLv2_server_method)] [(sslv2)
[(sslv3) (if client? SSLv2_client_method SSLv2_server_method)]
(if client? SSLv3_client_method SSLv3_server_method)] [(sslv3)
[(tls) (if client? SSLv3_client_method SSLv3_server_method)]
(if client? TLSv1_client_method TLSv1_server_method)] [(tls)
[(tls11) (if client? TLSv1_client_method TLSv1_server_method)]
(if client? TLSv1_1_client_method TLSv1_1_server_method)] [(tls11)
[(tls12) (if client? TLSv1_1_client_method TLSv1_1_server_method)]
(if client? TLSv1_2_client_method TLSv1_2_server_method)] [(tls12)
[else (if client? TLSv1_2_client_method TLSv1_2_server_method)]
(error 'encrypt->method "internal error, unknown encrypt: ~e" e)]))) [else
(error 'encrypt->method "internal error, unknown encrypt: ~e" e)]))
(unless f
(raise (exn:fail:unsupported
(format "~a: requested protocol not supported\n requested: ~e"
who
e)
(current-continuation-marks))))
(f))
(define (filter-available l)
(cond
[(null? l) null]
[(cadr l) (cons (car l) (filter-available (cddr l)))]
[else (filter-available (cddr l))]))
(define (supported-client-protocols)
(filter-available
(list 'sslv2-or-v3 SSLv23_client_method
'sslv2 SSLv2_client_method
'sslv3 SSLv3_client_method
'tls TLSv1_client_method
'tls11 TLSv1_1_client_method
'tls12 TLSv1_2_client_method)))
(define (supported-server-protocols)
(filter-available
(list 'sslv2-or-v3 SSLv23_server_method
'sslv2 SSLv2_server_method
'sslv3 SSLv3_server_method
'tls TLSv1_server_method
'tls11 TLSv1_1_server_method
'tls12 TLSv1_2_server_method)))
(define (make-context who protocol-symbol client?) (define (make-context who protocol-symbol client?)
(let ([meth (encrypt->method who protocol-symbol client?)]) (let ([meth (encrypt->method who protocol-symbol client?)])