From 0a95c50f7786796c7d585eed238066c8dba71d70 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 8 Apr 2021 15:26:01 +0200 Subject: [PATCH] openssl: add ALPN support for clients (#3765) --- pkgs/racket-doc/openssl/openssl.scrbl | 47 +++++++++++-- pkgs/racket-test/tests/openssl/test-alpn.rkt | 59 ++++++++++++++++ racket/collects/openssl/mzssl.rkt | 73 ++++++++++++++++---- 3 files changed, 162 insertions(+), 17 deletions(-) create mode 100644 pkgs/racket-test/tests/openssl/test-alpn.rkt diff --git a/pkgs/racket-doc/openssl/openssl.scrbl b/pkgs/racket-doc/openssl/openssl.scrbl index a93f5c4f01..ef07c701fc 100644 --- a/pkgs/racket-doc/openssl/openssl.scrbl +++ b/pkgs/racket-doc/openssl/openssl.scrbl @@ -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} diff --git a/pkgs/racket-test/tests/openssl/test-alpn.rkt b/pkgs/racket-test/tests/openssl/test-alpn.rkt new file mode 100644 index 0000000000..3e72dcba48 --- /dev/null +++ b/pkgs/racket-test/tests/openssl/test-alpn.rkt @@ -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) diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt index f9618e0b6f..b2350bc032 100644 --- a/racket/collects/openssl/mzssl.rkt +++ b/racket/collects/openssl/mzssl.rkt @@ -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