diff --git a/pkgs/racket-doc/openssl/openssl.scrbl b/pkgs/racket-doc/openssl/openssl.scrbl index 2a197c7fba..63c086792f 100644 --- a/pkgs/racket-doc/openssl/openssl.scrbl +++ b/pkgs/racket-doc/openssl/openssl.scrbl @@ -834,6 +834,26 @@ If @racket[ssl-peer-verified?] would return @racket[#t] for the certificate presented by the SSL port's peer, otherwise the result is @racket[#f].} +@defproc[(ssl-channel-binding [p ssl-port?] + [type (or/c 'tls-unique 'tls-server-end-point)]) + bytes?]{ + +Returns channel binding information for the TLS connection of +@racket[p]. An authentication protocol run over TLS can incorporate +information identifying the TLS connection (@racket['tls-unique]) or +server certificate (@racket['tls-server-end-point]) into the +authentication process, thus preventing the authentication steps from +being replayed on another channel. Channel binding is described in +general in @hyperlink["https://tools.ietf.org/html/rfc5056"]{RFC 5056}; +channel binding for TLS is described in +@hyperlink["https://tools.ietf.org/html/rfc5929"]{RFC 5929}. + +If the channel binding cannot be retrieved (for example, if the +connection is closed), an exception is raised. + +@history[#:added "7.7.0.9"]} + + @; ---------------------------------------------------------------------- @section{SHA-1 Hashing} diff --git a/pkgs/racket-test/tests/openssl/channel-binding/Makefile b/pkgs/racket-test/tests/openssl/channel-binding/Makefile new file mode 100644 index 0000000000..36208e5172 --- /dev/null +++ b/pkgs/racket-test/tests/openssl/channel-binding/Makefile @@ -0,0 +1,5 @@ +server: server.c + gcc -o server server.c `pkg-config gnutls --cflags --libs` + +clean: + rm server diff --git a/pkgs/racket-test/tests/openssl/channel-binding/server.c b/pkgs/racket-test/tests/openssl/channel-binding/server.c new file mode 100644 index 0000000000..ccbb601e82 --- /dev/null +++ b/pkgs/racket-test/tests/openssl/channel-binding/server.c @@ -0,0 +1,133 @@ +/* + Test server for tls-unique channel binding + + This implements a TLS "server" that accepts a single connection, + completes the TLS handshake, and then prints the connection's + tls-unique channel binding information and exits. + + It is adapted from code at https://www.gnutls.org/manual/gnutls.html, + specifically: + - 7.2.1 Echo server with X.509 authentication + - 6.12.8 Channel bindings + + Used by "../test-channel-binding.rkt". +*/ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* + Note: relative to dynamic current directory, not this source + file. See "../test-channel-binding.rkt" and files in "../". +*/ +#define KEYFILE "server_key.pem" +#define CERTFILE "server_crt.pem" +#define CAFILE "/etc/ssl/certs/ca-certificates.crt" + +#define CHECK(x) assert((x)>=0) +#define LOOP_CHECK(rval, cmd) \ + do { \ + rval = cmd; \ + } while(rval == GNUTLS_E_AGAIN || rval == GNUTLS_E_INTERRUPTED) + +#define PORT 5556 /* listen to 5556 port */ + +static void print_channel_binding(gnutls_session_t session); + +int main(void) +{ + int listen_sd; + int sd, ret; + gnutls_certificate_credentials_t x509_cred; + gnutls_priority_t priority_cache; + struct sockaddr_in sa_serv; + struct sockaddr_in sa_cli; + socklen_t client_len; + gnutls_session_t session; + int optval = 1; + + /* for backwards compatibility with gnutls < 3.3.0 */ + CHECK(gnutls_global_init()); + CHECK(gnutls_certificate_allocate_credentials(&x509_cred)); + CHECK(gnutls_certificate_set_x509_trust_file(x509_cred, CAFILE, + GNUTLS_X509_FMT_PEM)); + CHECK(gnutls_certificate_set_x509_key_file(x509_cred, CERTFILE, + KEYFILE, + GNUTLS_X509_FMT_PEM)); + CHECK(gnutls_priority_init(&priority_cache, NULL, NULL)); + + listen_sd = socket(AF_INET, SOCK_STREAM, 0); + memset(&sa_serv, '\0', sizeof(sa_serv)); + sa_serv.sin_family = AF_INET; + sa_serv.sin_addr.s_addr = INADDR_ANY; + sa_serv.sin_port = htons(PORT); /* Server Port number */ + setsockopt(listen_sd, SOL_SOCKET, SO_REUSEADDR, (void *) &optval, + sizeof(int)); + bind(listen_sd, (struct sockaddr *) &sa_serv, sizeof(sa_serv)); + listen(listen_sd, 1024); + + client_len = sizeof(sa_cli); + + { + CHECK(gnutls_init(&session, GNUTLS_SERVER)); + CHECK(gnutls_priority_set(session, priority_cache)); + CHECK(gnutls_credentials_set(session, GNUTLS_CRD_CERTIFICATE, + x509_cred)); + gnutls_certificate_server_set_request(session, + GNUTLS_CERT_IGNORE); + gnutls_handshake_set_timeout(session, + GNUTLS_DEFAULT_HANDSHAKE_TIMEOUT); + + sd = accept(listen_sd, (struct sockaddr *) &sa_cli, + &client_len); + + gnutls_transport_set_int(session, sd); + + LOOP_CHECK(ret, gnutls_handshake(session)); + if (ret < 0) { + close(sd); + gnutls_deinit(session); + fprintf(stderr, + "*** Handshake has failed (%s)\n\n", + gnutls_strerror(ret)); + exit(-1); + } + + print_channel_binding(session); + } + + close(listen_sd); + + gnutls_certificate_free_credentials(x509_cred); + gnutls_priority_deinit(priority_cache); + gnutls_global_deinit(); + return 0; +} + +static void print_channel_binding(gnutls_session_t session) { + gnutls_datum_t cb; + int rc; + + rc = gnutls_session_channel_binding (session, + GNUTLS_CB_TLS_UNIQUE, + &cb); + if (rc) { + fprintf (stderr, "Channel binding error: %s\n", + gnutls_strerror (rc)); + } else { + size_t i; + printf ("tls-unique "); + for (i = 0; i < cb.size; i++) + printf ("%02x", cb.data[i]); + printf ("\n"); + } +} diff --git a/pkgs/racket-test/tests/openssl/test-channel-binding.rkt b/pkgs/racket-test/tests/openssl/test-channel-binding.rkt new file mode 100644 index 0000000000..d1ccb7fbd6 --- /dev/null +++ b/pkgs/racket-test/tests/openssl/test-channel-binding.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require openssl + rackunit + racket/runtime-path) + +(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 this-dir ".") + +(define (call/custodian proc) + (define cust (make-custodian)) + (parameterize ((current-custodian cust)) + (dynamic-wind void proc (lambda () (custodian-shutdown-all cust))))) + +;; ---------------------------------------- + +(define PORT 55009) + +(define (get-cb port) + (list (ssl-channel-binding port 'tls-unique) + (ssl-channel-binding port 'tls-server-end-point))) + +(define server-ctx + (ssl-make-server-context 'auto + #:private-key `(pem ,server-key) + #:certificate-chain server-crt)) + +(test-case "channel binding agreement" + (call/custodian + (lambda () + (define chan (make-channel)) + (define listener (ssl-listen PORT 4 #t "localhost" server-ctx)) + (thread (lambda () + (define-values (sin sout) (ssl-accept listener)) + (channel-put chan (get-cb sin)) + (channel-put chan (get-cb sout)))) + (define-values (cin cout) (ssl-connect "localhost" PORT)) + (define client-cb (get-cb cin)) + (define server-cb1 (channel-get chan)) + (define server-cb2 (channel-get chan)) + (check-equal? client-cb server-cb1) + (check-equal? client-cb server-cb2) + (check-equal? client-cb (get-cb cout))))) + +;; ---------------------------------------- + +(define PORT2 5556) ;; must agree with channel-binding/server.c + +(require racket/promise + racket/port + racket/system + (only-in openssl/sha1 bytes->hex-string)) + +(define-runtime-path server-bin "channel-binding/server") + +(cond [(and (file-exists? server-bin) + (memq 'execute (file-or-directory-permissions server-bin))) + (test-case "channel binding agrees w/ gnutls server" + (parameterize ((current-subprocess-custodian-mode 'kill) + (current-directory this-dir)) + (call/custodian + (lambda () + (define server-cb + (delay/thread (with-output-to-string (lambda () (system* server-bin))))) + (sleep 0.2) ;; let the server get started + (define-values (cin cout) (ssl-connect "localhost" PORT2)) + (define client-cb + (format "tls-unique ~a\n" + (bytes->hex-string (ssl-channel-binding cin 'tls-unique)))) + (check-equal? client-cb (force server-cb))))))] + [else (printf "Skipped test against gnutls.\n")]) + +;; FIXME: find external test for tls-server-end-point? diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt index b46f4aa2a8..f9618e0b6f 100644 --- a/racket/collects/openssl/mzssl.rkt +++ b/racket/collects/openssl/mzssl.rkt @@ -161,6 +161,8 @@ TO DO: (c-> ssl-port? (or/c bytes? #f))] [ssl-peer-issuer-name (c-> ssl-port? (or/c bytes? #f))] + [ssl-channel-binding + (c-> ssl-port? (or/c 'tls-unique 'tls-server-end-point) bytes?)] [ports->ssl-ports (->* [input-port? output-port?] @@ -325,6 +327,8 @@ TO DO: #:wrap (deallocator)) (define-ssl SSL_get_peer_certificate (_fun _SSL* -> _X509*/null) #:wrap (allocator X509_free)) +(define-ssl SSL_get_certificate (_fun _SSL* -> _X509*/null) + #:wrap (allocator X509_free)) (define-crypto X509_get_subject_name (_fun _X509* -> _X509_NAME*)) (define-crypto X509_get_issuer_name (_fun _X509* -> _X509_NAME*)) @@ -370,6 +374,26 @@ TO DO: (define-crypto X509_get_default_cert_dir_env (_fun -> _string)) (define-crypto X509_get_default_cert_file_env (_fun -> _string)) +(define-ssl SSL_get_peer_finished (_fun _SSL* _pointer _size -> _size)) +(define-ssl SSL_get_finished (_fun _SSL* _pointer _size -> _size)) + +(define-cpointer-type _EVP_MD*) +(define-crypto EVP_sha224 (_fun -> _EVP_MD*/null)) +(define-crypto EVP_sha256 (_fun -> _EVP_MD*/null)) +(define-crypto EVP_sha384 (_fun -> _EVP_MD*/null)) +(define-crypto EVP_sha512 (_fun -> _EVP_MD*/null)) +(define-crypto EVP_MD_size (_fun _EVP_MD* -> _int)) + +(define-ssl OBJ_find_sigid_algs + (_fun _int (alg : (_ptr o _int)) (_pointer = #f) -> (r : _int) + -> (if (> r 0) alg 0))) + +(define-ssl X509_get_signature_nid + (_fun _X509* -> _int)) + +(define-ssl X509_digest + (_fun _X509* _EVP_MD* _pointer (_ptr i _uint) -> _int)) + (define (x509-root-sources) (cond [libcrypto @@ -481,6 +505,13 @@ TO DO: (define SSL_TLSEXT_ERR_OK 0) (define SSL_TLSEXT_ERR_NOACK 3) +(define NID_md5 4) +(define NID_sha1 64) +(define NID_sha224 675) +(define NID_sha256 672) +(define NID_sha384 673) +(define NID_sha512 674) + (define ssl-dh4096-param-bytes (include/reader "dh4096.pem" (lambda (src port) (let loop ([accum '()]) @@ -1686,6 +1717,43 @@ TO DO: [lit-rxs (for/list ([part (in-list lit-parts)]) (regexp-quote part #f))]) (regexp (string-join lit-rxs ".*")))) +(define (ssl-channel-binding p type) + ;; Reference: https://tools.ietf.org/html/rfc5929 + (define who 'ssl-channel-binding) + (define-values (mzssl _in?) (lookup 'ssl-channel-binding p)) + (define ssl (mzssl-ssl mzssl)) + (case type + [(tls-unique) + (define MAX_FINISH_LEN 50) ;; usually 12 bytes, but be cautious (see RFC 5246 7.4.9) + (define get-finished ;; assumes no session resumption + (cond [(mzssl-server? mzssl) SSL_get_peer_finished] + [else SSL_get_finished])) + (define buf (make-bytes MAX_FINISH_LEN)) + (define r (get-finished ssl buf (bytes-length buf))) + (cond [(zero? r) (error who "unable to get TLS Finished message")] + [(< 0 r MAX_FINISH_LEN) (subbytes buf 0 r)] + [else (error who "internal error: TLS Finished message too large")])] + [(tls-server-end-point) + (define x509 + (cond [(mzssl-server? mzssl) (SSL_get_certificate ssl)] + [else (SSL_get_peer_certificate ssl)])) + (unless x509 (error who "failed to get server certificate")) + (define sig-nid (X509_get_signature_nid x509)) + (define hash-nid (OBJ_find_sigid_algs sig-nid)) + (define hash-evp ;; change md5, sha1 to sha256, per RFC 5929 4.1 + (cond [(or (= hash-nid NID_md5) (= hash-nid NID_sha1)) (EVP_sha256)] + [(= hash-nid NID_sha224) (EVP_sha224)] + [(= hash-nid NID_sha256) (EVP_sha256)] + [(= hash-nid NID_sha384) (EVP_sha384)] + [(= hash-nid NID_sha512) (EVP_sha512)] + [else (error who "unsupported digest in certificate")])) + (define buflen (EVP_MD_size hash-evp)) + (unless (> buflen 0) (error who "internal error: bad digest length")) + (define buf (make-bytes buflen)) + (define r (X509_digest x509 hash-evp buf buflen)) + (X509_free x509) + (if (> r 0) buf (error who "internal error: certificate digest failed"))])) + (define (ssl-port? v) (and (hash-ref ssl-ports v #f) #t))