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

openssl: add ALPN support for clients (#3765)

Browse Source
This commit is contained in:
Ryan Culpepper 2021-04-08 15:26:01 +02:00 committed by GitHub
parent 24c6b2450c
commit 0a95c50f77
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 162 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,6 +15,9 @@
(define sha1-bytes-id @racket[sha1-bytes])))
@(define-racket/base racket:sha1-bytes)
@(define alpn-url
"https://en.wikipedia.org/wiki/Application-Layer_Protocol_Negotiation")
@title{OpenSSL: Secure Communication}
@defmodule[openssl]
@ -77,7 +80,8 @@ using the functions described in @secref["cert-procs"].
'secure
'auto
'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12)
'auto])
'auto]
[#:alpn alpn-protocols (listof bytes?) null])
(values input-port? output-port?)]{
Connect to the host given by @racket[hostname], on the port given by
@ -103,6 +107,12 @@ If hostname verification is enabled (see
@racket[ssl-set-verify-hostname!]), the peer's certificate is checked
against @racket[hostname].
If @racket[alpn-protocols] is not empty, the client attempts to use
@hyperlink[alpn-url]{ALPN} to negotiate the application-level
protocol. The protocols should be listed in order of preference, and
each protocol must be a byte string with a length between 1 and 255
(inclusive). See also @racket[ssl-get-alpn-selected].
@;{
See `enforce-retry?' in "mzssl.rkt", currently set to #f so that this
paragraph does not apply:
@ -119,7 +129,8 @@ whether the other end is supposed to be sending or reading data.
}
@history[#:changed "6.3.0.12" @elem{Added @racket['secure] for
@racket[client-protocol].}]}
@racket[client-protocol].}
#:changed "8.0.0.13" @elem{Added @racket[#:alpn] argument.}]}
@defproc[(ssl-connect/enable-break
[hostname string?]
@ -414,7 +425,8 @@ current platform for server connections.
[#:close-original? close-original? boolean? #f]
[#:shutdown-on-close? shutdown-on-close? boolean? #f]
[#:error/ssl error procedure? error]
[#:hostname hostname (or/c string? #f) #f])
[#:hostname hostname (or/c string? #f) #f]
[#:alpn alpn-protocols (listof bytes?) null])
(values input-port? output-port?)]{
Returns two values---an input port and an output port---that
@ -464,7 +476,15 @@ writing to an SSL connection (i.e., one direction at a time).
If hostname verification is enabled (see
@racket[ssl-set-verify-hostname!]), the peer's certificate is checked
against @racket[hostname].
}
If @racket[alpn-protocols] is not empty and @racket[mode] is
@racket['connect], then the client attempts to use
@hyperlink[alpn-url]{ALPN}; see also @racket[ssl-connect] and
@racket[ssl-get-alpn-selected]. If @racket[alpn-protocols] is not
empty and @racket[mode] is @racket['accept], an exception
(@racket[exn:fail]) is raised.
@history[#:changed "8.0.0.13" @elem{Added @racket[#:alpn] argument.}]}
@; ----------------------------------------------------------------------
@ -856,6 +876,25 @@ connection is closed), an exception is raised.
@history[#:added "7.7.0.9"]}
@defproc[(ssl-get-alpn-selected [p ssl-port?])
(or/c bytes? #f)]{
Returns the ALPN protocol selected during negotiation, or @racket[#f]
if no protocol was selected.
This library currently only supports ALPN for client connections.
According to @hyperlink["https://tools.ietf.org/html/rfc7301"]{RFC
7301}, if a server does not support any of the protocols proposed by
the client, it must reject the connection with a
``no_application_protocol'' alert. In practice, however, some servers
simply continue without selecting an application protocol (see
@hyperlink["https://github.com/openssl/openssl/issues/2708"]{this
OpenSSL bug}, for example), so it is recommended to always check the
selected protocol after making a connection.
@history[#:added "8.0.0.13"]}
@; ----------------------------------------------------------------------
@section{SHA-1 Hashing}

59
pkgs/racket-test/tests/openssl/test-alpn.rkt Normal file
View File

@ -0,0 +1,59 @@
#lang racket/base
(require openssl
rackunit
racket/tcp
racket/runtime-path
racket/system)
;; Tests for ALPN client support
(define-runtime-path server-key "server_key.pem")
(define-runtime-path server-crt "server_crt.pem")
;; server listens on localhost:PORT+counter
;; (need to change port, otherwise get "Address still in use")
(define PORT 4493)
;; Set up server
(define server-cust (make-custodian))
(define srvout (open-output-string))
(define-values (_srvout _srvin srvpid _srverr srvctl)
(parameterize ((current-custodian server-cust)
(current-subprocess-custodian-mode 'kill))
(apply values
(process* "/usr/bin/openssl" "s_server"
"-accept" (number->string PORT)
"-cert" server-crt "-key" server-key
"-alpn" "rkt-proto,other"))))
(sleep 0.2) ;; wait for server to bind the port
(let ()
;; Check no protocol is selected if none is requested.
(define-values (in out)
(ssl-connect "localhost" PORT))
(check-equal? (ssl-get-alpn-selected in) #f)
(check-equal? (ssl-get-alpn-selected out) #f)
(begin (close-input-port in) (close-output-port out)))
(let ()
;; Check supported protocol is selected.
(define-values (in out)
(ssl-connect "localhost" PORT #:alpn '(#"rkt-proto")))
(check-equal? (ssl-get-alpn-selected in) #"rkt-proto")
(check-equal? (ssl-get-alpn-selected out) #"rkt-proto")
(begin (close-input-port in) (close-output-port out)))
(let ()
;; Check unsupported protocol is not selected.
(define-values (in out)
(ssl-connect "localhost" PORT #:alpn '(#"unsupported" #"rkt-proto")))
(check-equal? (ssl-get-alpn-selected in) #"rkt-proto")
(check-equal? (ssl-get-alpn-selected out) #"rkt-proto")
(begin (close-input-port in) (close-output-port out)))
;; Don't test case when client requests only unsupported protocols,
;; because there are buggy versions of OpenSSL that accept the
;; connection without setting a protocol. (Spec says connection
;; should fail.)
(custodian-shutdown-all server-cust)

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

@ -49,6 +49,9 @@ TO DO:
(define protocol-symbol/c
(or/c 'secure 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12))
(define (alpn-protocol-bytes/c v)
(and (bytes? v) (< 0 (bytes-length v) 256)))
(define curve-nid-alist
'((sect163k1 . 721)
(sect163r1 . 722)
@ -163,6 +166,8 @@ TO DO:
(c-> ssl-port? (or/c bytes? #f))]
[ssl-channel-binding
(c-> ssl-port? (or/c 'tls-unique 'tls-server-end-point) bytes?)]
[ssl-get-alpn-selected
(c-> ssl-port? (or/c bytes? #f))]
[ports->ssl-ports
(->* [input-port?
output-port?]
@ -172,7 +177,8 @@ TO DO:
#:close-original? any/c
#:shutdown-on-close? any/c
#:error/ssl procedure?
#:hostname (or/c string? #f)]
#:hostname (or/c string? #f)
#:alpn (listof alpn-protocol-bytes/c)]
(values input-port? output-port?))]
[ssl-listen
(->* [listen-port-number?]
@ -192,12 +198,14 @@ TO DO:
[ssl-connect
(->* [string?
(integer-in 1 (sub1 (expt 2 16)))]
[(or/c ssl-client-context? protocol-symbol/c)]
[(or/c ssl-client-context? protocol-symbol/c)
#:alpn (listof alpn-protocol-bytes/c)]
(values input-port? output-port?))]
[ssl-connect/enable-break
(->* [string?
(integer-in 1 (sub1 (expt 2 16)))]
[(or/c ssl-client-context? protocol-symbol/c)]
[(or/c ssl-client-context? protocol-symbol/c)
#:alpn (listof alpn-protocol-bytes/c)]
(values input-port? output-port?))]
[ssl-listener?
(c-> any/c boolean?)]
@ -377,6 +385,27 @@ TO DO:
(define-ssl SSL_get_peer_finished (_fun _SSL* _pointer _size -> _size))
(define-ssl SSL_get_finished (_fun _SSL* _pointer _size -> _size))
(define-ssl SSL_CTX_set_alpn_protos
(_fun _SSL_CTX*
(bs : _bytes)
(_uint = (bytes-length bs))
-> _int)) ;; Note: 0 means success, other means failure!
(define-ssl SSL_set_alpn_protos
(_fun _SSL*
(bs : _bytes)
(_uint = (bytes-length bs))
-> _int)) ;; Note: 0 means success, other means failure!
(define-ssl SSL_get0_alpn_selected
(_fun _SSL*
(p : (_ptr o _pointer))
(len : (_ptr o _uint))
-> _void
-> (cond [(and p (> len 0))
(let ([bs (make-bytes len)])
(memcpy bs p len)
bs)]
[else #f])))
(define-cpointer-type _EVP_MD*)
(define-crypto EVP_sha224 (_fun -> _EVP_MD*/null))
(define-crypto EVP_sha256 (_fun -> _EVP_MD*/null))
@ -1470,10 +1499,11 @@ TO DO:
#:close-original? [close-original? #f]
#:shutdown-on-close? [shutdown-on-close? #f]
#:error/ssl [error/ssl error]
#:hostname [hostname #f])
#:hostname [hostname #f]
#:alpn [alpn null])
(wrap-ports 'port->ssl-ports i o (or context encrypt) mode
close-original? shutdown-on-close? error/ssl
hostname))
hostname alpn))
(define (create-ssl who context-or-encrypt-method connect/accept error/ssl)
(define connect?
@ -1519,10 +1549,10 @@ TO DO:
(define (wrap-ports who i o context-or-encrypt-method connect/accept
close? shutdown-on-close? error/ssl
hostname)
hostname alpn)
;; Create the SSL connection:
(let-values ([(ssl r-bio w-bio connect?)
(create-ssl who context-or-encrypt-method connect/accept error/ssl)]
(create-ssl who context-or-encrypt-method connect/accept error/ssl)]
[(verify-hostname?)
(cond [(ssl-context? context-or-encrypt-method)
(ssl-context-verify-hostname? context-or-encrypt-method)]
@ -1530,6 +1560,14 @@ TO DO:
(when (string? hostname)
(SSL_ctrl/bytes ssl SSL_CTRL_SET_TLSEXT_HOSTNAME
TLSEXT_NAMETYPE_host_name (string->bytes/latin-1 hostname)))
(when (pair? alpn)
(unless (eq? connect/accept 'connect)
(error who "ALPN is currently supported only in connect mode"))
(define proto-list
(apply bytes-append (for/list ([proto (in-list alpn)])
(bytes-append (bytes (bytes-length proto)) proto))))
(unless (zero? (SSL_set_alpn_protos ssl proto-list))
(error who "failed setting ALPN protocol list")))
;; connect/accept:
(let-values ([(buffer) (make-bytes BUFFER-SIZE)]
@ -1754,6 +1792,11 @@ TO DO:
(X509_free x509)
(if (> r 0) buf (error who "internal error: certificate digest failed"))]))
(define (ssl-get-alpn-selected p)
(define-values (mzssl _in?) (lookup 'ssl-get-alpn-selected p))
(define ssl (mzssl-ssl mzssl))
(SSL_get0_alpn_selected ssl))
(define (ssl-port? v)
(and (hash-ref ssl-ports v #f) #t))
@ -1799,7 +1842,7 @@ TO DO:
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SSL connect
(define (do-ssl-connect who tcp-connect hostname port-k client-context-or-protocol-symbol)
(define (do-ssl-connect who tcp-connect hostname port-k client-context-or-protocol-symbol alpn)
(let-values ([(i o) (tcp-connect hostname port-k)])
;; See do-ssl-accept for note on race condition here:
(with-handlers ([void (lambda (exn)
@ -1807,23 +1850,27 @@ TO DO:
(close-output-port o)
(raise exn))])
(wrap-ports who i o client-context-or-protocol-symbol 'connect #t #f error/network
hostname))))
hostname alpn))))
(define (ssl-connect hostname port-k
[client-context-or-protocol-symbol default-encrypt])
[client-context-or-protocol-symbol default-encrypt]
#:alpn [alpn null])
(do-ssl-connect 'ssl-connect
tcp-connect
hostname
port-k
client-context-or-protocol-symbol))
client-context-or-protocol-symbol
alpn))
(define (ssl-connect/enable-break hostname port-k
[client-context-or-protocol-symbol default-encrypt])
[client-context-or-protocol-symbol default-encrypt]
#:alpn [alpn null])
(do-ssl-connect 'ssl-connect/enable-break
tcp-connect/enable-break
hostname
port-k
client-context-or-protocol-symbol))
client-context-or-protocol-symbol
alpn))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization