ADDED: Application-Layer Protocol Negotiation (ALPN) support. ALPN is

required for HTTP/2.  Provided by James Cash with comments from Markus
Triska and Jan Wielemaker.

configure.ac

@@ -116,6 +116,7 @@ AC_CHECK_FUNCS(EVP_CIPHER_CTX_reset)
 AC_CHECK_FUNCS(EVP_blake2b512 EVP_blake2s256)
 AC_CHECK_FUNCS(EVP_sha3_224 EVP_sha3_256 EVP_sha3_384 EVP_sha3_512)
 AC_CHECK_FUNCS(HMAC_CTX_new HMAC_CTX_free)
+AC_CHECK_FUNCS(SSL_CTX_set_alpn_protos)
 
 AC_CHECK_HEADERS(openssl/kdf.h)
 

ssl.pl

@@ -79,7 +79,9 @@
                        peer_cert(boolean),
                        close_parent(boolean),
                        close_notify(boolean),
-                       sni_hook(callable)
+                       sni_hook(callable),
+                       alpn_protocols(any),
+                       alpn_protocol_hook(callable)
                      ]).
 
 /** <module> Secure Socket Layer (SSL) library
@@ -273,6 +275,20 @@
 %     used, which are those of the encompassing ssl_context/3
 %     call. In that case, if no default certificate and key are
 %     specified, the client connection is rejected.
+%     * alpn_protocols(+ListOfProtoIdentifiers)
+%     Provide a list of acceptable ALPN protocol identifiers as atoms.
+%     ALPN support requires OpenSSL 1.0.2 or greater.
+%     * alpn_protocol_hook(:Goal)
+%     This options provides a callback for a server context to use to
+%     select an ALPN protocol. It will be called as follows:
+%
+%     ===
+%     call(Goal, +SSLCtx0, +ListOfClientProtocols, -SSLCtx1, -SelectedProtocol)
+%     ===
+%
+%     If this option is unset and the `alpn_protocols/1` option is
+%     set, then the first common protocol between client & server will
+%     be selected.
 %
 %   @arg Role is one of `server` or `client` and denotes whether the
 %   SSL  instance  will  have  a  server   or  client  role  in  the
@@ -313,11 +329,11 @@
 %   Options.  The following options are supported: close_notify/1,
 %   close_parent/1, host/1, peer_cert/1, ecdh_curve/1,
 %   min_protocol_version/1, max_protocol_version/1,
-%   disable_ssl_methods/1, sni_hook/1, cert_verify_hook/1. See
-%   ssl_context/3 for more information about these options. This
-%   predicate allows you to tweak existing SSL contexts, which can be
-%   useful in hooks when creating servers with the HTTP
-%   infrastructure.
+%   disable_ssl_methods/1, sni_hook/1, cert_verify_hook/1,
+%   alpn_protocols/1, and alpn_protocol_hook/1. See ssl_context/3 for
+%   more information about these options. This predicate allows you to
+%   tweak existing SSL contexts, which can be useful in hooks when
+%   creating servers with the HTTP infrastructure.
 
 ssl_set_options(SSL0, SSL, Options) :-
     ssl_copy_context(SSL0, SSL),
@@ -392,6 +408,9 @@
 %     The SSLv3 session ID. Note that if ECDHE is being used (which
 %     is the default for newer versions of OpenSSL), this data will
 %     not actually be sent to the server.
+%     * alpn_protocol(Protocol)
+%     The negotiated ALPN protocol, if supported. If no protocol was
+%     negotiated, this will be an empty string.
 
 %!  load_certificate(+Stream, -Certificate) is det.
 %

ssl4pl.c

@@ -1,7 +1,7 @@
 /*  Part of SWI-Prolog
 
-    Author:        Jan van der Steen, Jan Wielemaker, Matt Lilley
-		   and Markus Triska
+    Author:        Jan van der Steen, Jan Wielemaker, Matt Lilley,
+		   Markus Triska and James Cash
     E-mail:        J.Wielemaker@vu.nl
     WWW:           http://www.swi-prolog.org
     Copyright (c)  2004-2018, SWI-Prolog Foundation
@@ -96,6 +96,8 @@ static atom_t ATOM_cipher_list;
 static atom_t ATOM_ecdh_curve;
 static atom_t ATOM_root_certificates;
 static atom_t ATOM_sni_hook;
+static atom_t ATOM_alpn_protocols;
+static atom_t ATOM_alpn_protocol_hook;
 
 static atom_t ATOM_sslv2;
 static atom_t ATOM_sslv23;
@@ -141,6 +143,7 @@ static functor_t FUNCTOR_client_random1;
 static functor_t FUNCTOR_server_random1;
 static functor_t FUNCTOR_system1;
 static functor_t FUNCTOR_unknown1;
+static functor_t FUNCTOR_alpn_protocol1;
 
 typedef enum
 { PL_SSL_NONE
@@ -232,9 +235,12 @@ typedef struct pl_ssl {
     PL_SSL_CALLBACK      cb_cert_verify;
     PL_SSL_CALLBACK      cb_pem_passwd;
     PL_SSL_CALLBACK      cb_sni;
+    PL_SSL_CALLBACK      cb_alpn_proto;
 #ifndef HAVE_X509_CHECK_HOST
     int                  hostname_check_status;
 #endif
+    unsigned char       *alpn_protos;
+    size_t               alpn_protos_len;
 } PL_SSL;
 
 typedef struct ssl_instance {
@@ -1604,9 +1610,12 @@ ssl_new(void)
         new->cb_sni.goal         = NULL;
         new->cb_cert_verify.goal = NULL;
         new->cb_pem_passwd.goal  = NULL;
+        new->cb_alpn_proto.goal  = NULL;
 #ifndef HAVE_X509_CHECK_HOST
         new->hostname_check_status = 0;
 #endif
+        new->alpn_protos         = NULL;
+        new->alpn_protos_len     = 0;
         new->magic                 = SSL_CONFIG_MAGIC;
     }
     ssl_deb(1, "Allocated config structure\n");
@@ -1642,6 +1651,8 @@ ssl_free(PL_SSL *config)
     if (config->cb_sni.goal) PL_erase(config->cb_sni.goal);
     if (config->cb_pem_passwd.goal) PL_erase(config->cb_pem_passwd.goal);
     if (config->cb_cert_verify.goal) PL_erase(config->cb_cert_verify.goal);
+    if (config->cb_alpn_proto.goal) PL_erase(config->cb_alpn_proto.goal);
+    if (config->alpn_protos) free(config->alpn_protos);
 
     free(config);
     ssl_deb(1, "Released config structure\n");
@@ -2511,6 +2522,113 @@ ssl_init_min_max_protocol(PL_SSL *config)
 #endif
 }
 
+static int
+ssl_server_alpn_select_cb(SSL *ssl,
+			  const unsigned char **out, unsigned char *outlen,
+			  const unsigned char *in, unsigned int inlen,
+			  void *arg)
+{ PL_SSL *config = (PL_SSL*)arg;
+
+  if ( config->cb_alpn_proto.goal )
+  { fid_t fid;
+    int ret = SSL_TLSEXT_ERR_ALERT_FATAL;
+
+    if ( (fid = PL_open_foreign_frame()) )
+    { term_t av, protos_list, protos_list_tail, head;
+      unsigned int in_pos = 0;
+
+      if ( !(av = PL_new_term_refs(5)) ||
+	   !(protos_list = PL_new_term_ref()) ||
+	   !(protos_list_tail = PL_copy_term_ref(protos_list)) ||\
+	   !(head = PL_new_term_ref()) ||
+	   !PL_put_list(protos_list) )
+	goto out;
+
+      while (in_pos < inlen)
+      { unsigned char proto_len = in[in_pos];
+	const unsigned char* proto = in + in_pos + 1;
+
+	if ( !PL_unify_list_ex(protos_list_tail, head, protos_list_tail) ||
+	     !PL_unify_chars(head, PL_ATOM|REP_UTF8, proto_len, (char*)proto) )
+	  goto out;
+	in_pos += proto_len + 1;
+      }
+      if ( !PL_unify_nil(protos_list_tail) )
+	goto out;
+
+      predicate_t call5 = PL_predicate("call", 5, "system");
+
+      /*
+       * call(CB, +SSL0, +ClientProtos, -SSL1, -SelectedProtocol)
+       */
+      if ( !PL_recorded(config->cb_alpn_proto.goal, av+0) ||
+	   !PL_put_atom(av+1, config->atom) ||
+	   !PL_unify(av+2, protos_list) )
+	goto out;
+
+      if ( !PL_call_predicate(config->cb_alpn_proto.module,
+	                      PL_Q_PASS_EXCEPTION, call5, av) )
+	goto out;
+
+      PL_SSL *new_config = NULL;
+      if ( !get_conf(av+3, &new_config) )
+      { PL_warning("alpn_protocol_hook return wrong type");
+	goto out;
+      }
+      SSL_set_SSL_CTX(ssl, new_config ? new_config->ctx : config->ctx);
+
+      char *str;
+      size_t olen;
+      if ( PL_get_nchars(av+4, &olen, &str,
+			 CVT_ATOM|CVT_STRING|REP_UTF8|CVT_EXCEPTION) )
+      { unsigned int i = 0;
+
+        while (i < inlen)
+        { unsigned char plen = in[i];
+          const unsigned char *pstr = in + i + 1;
+          if ( plen == olen && strncmp(str, (const char*)pstr, plen) == 0 )
+            { *out = pstr;
+              *outlen = plen;
+              ret = SSL_TLSEXT_ERR_OK;
+              goto out;
+            }
+          i += plen + 1;
+        }
+      } else
+      { PL_domain_error("alpn protocol", av+4);
+      }
+
+    out:
+      PL_close_foreign_frame(fid);
+    }
+
+    return ret;
+  } else
+  { int ret = SSL_select_next_proto((unsigned char**)out, outlen,
+				    config->alpn_protos, config->alpn_protos_len,
+				    in, inlen);
+    if ( ret == OPENSSL_NPN_NEGOTIATED )
+      return SSL_TLSEXT_ERR_OK;
+    else
+      return SSL_TLSEXT_ERR_ALERT_FATAL;
+  }
+}
+
+static void
+ssl_init_alpn_protos(PL_SSL *config)
+{
+#ifdef HAVE_SSL_CTX_SET_ALPN_PROTOS
+  if ( config->alpn_protos ||
+       ( config->role == PL_SSL_SERVER && config->cb_alpn_proto.goal ) ) {
+    if ( config->role == PL_SSL_CLIENT ) {
+      SSL_CTX_set_alpn_protos(config->ctx, config->alpn_protos, config->alpn_protos_len);
+    } else if ( config->role == PL_SSL_SERVER ) {
+      SSL_CTX_set_alpn_select_cb(config->ctx, &ssl_server_alpn_select_cb, config);
+    }
+  }
+#endif
+}
+
 static int
 set_malleable_options(PL_SSL *config)
 {
@@ -2558,6 +2676,7 @@ set_malleable_options(PL_SSL *config)
 
   ssl_init_sni(config);
   ssl_init_min_max_protocol(config);
+  ssl_init_alpn_protos(config);
 
   return TRUE;
 }
@@ -2984,6 +3103,44 @@ parse_malleable_options(PL_SSL *conf, module_t module, term_t options)
 	return FALSE;
 
       conf->close_notify = val;
+    } else if ( name == ATOM_alpn_protocols && arity == 1 )
+    { term_t protos_tail = PL_new_term_ref();
+      term_t protos_head = PL_new_term_ref();
+      _PL_get_arg(1, head, protos_tail);
+      size_t current_size = 0;
+      unsigned char *protos_vec = NULL;
+      size_t total_length = 0;
+
+      while( PL_get_list_ex(protos_tail, protos_head, protos_tail) )
+      { char *proto;
+	size_t proto_len;
+
+        if ( !PL_get_nchars(protos_head, &proto_len, &proto,
+			    CVT_ATOM|CVT_STRING|CVT_EXCEPTION|REP_UTF8|BUF_RING) )
+          return FALSE;
+        total_length += proto_len + 1;
+        if ( total_length > current_size ) {
+          unsigned char* new_protos_vec = realloc(protos_vec, total_length);
+          if ( new_protos_vec == NULL ) {
+            if ( protos_vec != NULL ) free(protos_vec);
+            return PL_resource_error("memory");
+          } else {
+            protos_vec = new_protos_vec;
+          }
+        }
+        protos_vec[current_size] = proto_len;
+        memcpy(protos_vec + current_size + 1, proto, proto_len);
+        current_size = total_length;
+      }
+      conf->alpn_protos = protos_vec;
+      conf->alpn_protos_len = current_size;
+    } else if ( name == ATOM_alpn_protocol_hook && arity == 1 &&
+                conf->role == PL_SSL_SERVER )
+    { term_t cb = PL_new_term_ref();
+      _PL_get_arg(1, head, cb);
+      if ( conf->cb_alpn_proto.goal ) PL_erase(conf->cb_alpn_proto.goal);
+      conf->cb_alpn_proto.goal = PL_record(cb);
+      conf->cb_alpn_proto.module = module;
     } else
       continue;
   }
@@ -3378,13 +3535,22 @@ pl_ssl_init_from_context(term_t term_old, term_t term_new)
   ssl_copy_callback(old->cb_cert_verify, &new->cb_cert_verify);
   ssl_copy_callback(old->cb_pem_passwd, &new->cb_pem_passwd);
   ssl_copy_callback(old->cb_sni, &new->cb_sni);
+  ssl_copy_callback(old->cb_alpn_proto, &new->cb_alpn_proto);
 
   for (idx = 0; idx < old->num_cert_key_pairs; idx++)
   { new->cert_key_pairs[idx].certificate = ssl_strdup(old->cert_key_pairs[idx].certificate);
     new->cert_key_pairs[idx].key = ssl_strdup(old->cert_key_pairs[idx].key);
     new->num_cert_key_pairs++;
   }
 
+  if ( old->alpn_protos ) {
+    unsigned char *protos_copy = malloc(old->alpn_protos_len * sizeof(unsigned char));
+    if ( protos_copy == NULL )
+      return PL_resource_error("memory");
+    memcpy(old->alpn_protos, protos_copy, old->alpn_protos_len);
+    new->alpn_protos = protos_copy;
+  }
+
   return ssl_config(new);
 }
 
@@ -3620,6 +3786,17 @@ pl_ssl_session(term_t stream_t, term_t session_t)
   PL_free(master_key);
 #endif
 
+#ifdef HAVE_SSL_CTX_SET_ALPN_PROTOS
+  { const unsigned char *data;
+    unsigned int len;
+    SSL_get0_alpn_selected(ssl, &data, &len);
+    if ( !add_key_string(list_t, FUNCTOR_alpn_protocol1,
+                         len, data)) {
+      goto err;
+    }
+  }
+#endif
+
   SSL_SESSION_free(session);
   return PL_unify_nil_ex(list_t);
 
@@ -3666,6 +3843,8 @@ install_ssl4pl(void)
   MKATOM(tlsv1_3);
   MKATOM(require_crl);
   MKATOM(crl);
+  MKATOM(alpn_protocols);
+  MKATOM(alpn_protocol_hook);
 
   ATOM_minus                = PL_new_atom("-");
 
@@ -3700,6 +3879,7 @@ install_ssl4pl(void)
   FUNCTOR_session_id1       = PL_new_functor(PL_new_atom("session_id"), 1);
   FUNCTOR_client_random1    = PL_new_functor(PL_new_atom("client_random"), 1);
   FUNCTOR_server_random1    = PL_new_functor(PL_new_atom("server_random"), 1);
+  FUNCTOR_alpn_protocol1    = PL_new_functor(PL_new_atom("alpn_protocol"), 1);
   FUNCTOR_system1           = PL_new_functor(PL_new_atom("system"), 1);
   FUNCTOR_unknown1          = PL_new_functor(PL_new_atom("unknown"), 1);
   FUNCTOR_unsupported_hash_algorithm1 = PL_new_functor(PL_new_atom("unsupported_hash_algorithm"), 1);