add ssl-channel-binding (#3250)

add ssl-channel-binding

Additional references:
- https://bugs.python.org/issue12551
- https://paquier.xyz/postgresql-2/channel-binding-openssl/

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}

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

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 <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <arpa/inet.h>
+#include <netinet/in.h>
+#include <string.h>
+#include <unistd.h>
+#include <gnutls/gnutls.h>
+#include <assert.h>
+
+/*
+  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");
+  }
+}

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?

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))