/* Transport Layer Security implementation.
   Copyright (C) 2014 Jerry James

This file is part of XEmacs.

XEmacs is free software: you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation, either version 3 of the License, or (at your
option) any later version.

XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with XEmacs.  If not, see <http://www.gnu.org/licenses/>. */

/* Synched up with: Not in FSF. */

/* Written by Jerry James. */

#include <config.h>
#include "lisp.h"
#include "lstream.h"
#include "sysproc.h"
#include "tls.h"
#include <errno.h>

#ifdef WITH_TLS
static Lisp_Object prompt;
static Lisp_Object Qread_passwd;
#endif

#ifdef HAVE_NSS
#include <prinit.h>
#include <private/pprio.h>
#include <nss.h>
#include <pk11pub.h>
#include <secerr.h>
#include <secmod.h>
#include <ssl.h>

#define NSS_ERRSTR build_extstring (PR_ErrorToName (PR_GetError ()), Qnative)

/* 0 == initialization of NSPR or NSS failed
 * 1 == the NSPR and NSS libraries have been initialized successfully
 */
static int nss_inited;

/* The model file descriptor */
static PRFileDesc *nss_model;

/* The PEM module */
static SECMODModule *nss_pem_module;

/* CA and trust objects go into slot 0.  User certificates start in slot 1. */
static CK_SLOT_ID nss_slot_count = 1;

int
tls_get_fd (tls_state_t *state)
{
  return PR_FileDesc2NativeHandle (state->tls_file_desc);
}

Bytecount
tls_read (tls_state_t *state, unsigned char *data, Bytecount size,
	  unsigned int allow_quit)
{
  if (allow_quit)
    QUIT;
  return (Bytecount) PR_Recv (state->tls_file_desc, data, size, 0, 0);
}

Bytecount
tls_write (tls_state_t *state, const unsigned char *data, Bytecount size,
	   unsigned int allow_quit)
{
  if (allow_quit)
    QUIT;
  return (Bytecount) PR_Send (state->tls_file_desc, data, size, 0, 0);
}

int
tls_close (tls_state_t *state)
{
  if (--state->tls_refcount == 0)
    {
      PRStatus status = PR_Shutdown (state->tls_file_desc, PR_SHUTDOWN_BOTH);
      PR_Close (state->tls_file_desc);
      xfree (state);
      return (int) status;
     }
  return 0;
}

tls_state_t *
tls_open (int s, const Extbyte *hostname)
{
  union {
    struct sockaddr addr;
    struct sockaddr_in addr4;
    struct sockaddr_in6 addr6;
  } addr;
  socklen_t addrlen = sizeof (addr);
  PRNetAddr pr_addr;
  tls_state_t *nspr;
  const int val = 1;

  if (!nss_inited)
    {
      warn_when_safe (Qtls_error, Qerror, "Cannot use NSS functions");
      return NULL;
    }

  /* Disable Nagle's algorithm */
  setsockopt (s, IPPROTO_TCP, TCP_NODELAY, &val, sizeof(val));

  /* Get the socket address */
  if (getsockname (s, (struct sockaddr *) &addr, &addrlen) < 0)
    {
      warn_when_safe (Qtls_error, Qerror, "Error in getsockname: %s",
                      strerror (errno));
      return NULL;
    }

  /* Create the socket */
  nspr = (tls_state_t *) xmalloc (sizeof (*nspr));
  nspr->tls_refcount = 2;
  nspr->tls_file_desc =
    SSL_ImportFD (nss_model, PR_OpenTCPSocket (addr.addr.sa_family));
  if (nspr->tls_file_desc == NULL)
    {
      xfree (nspr);
      warn_when_safe (Qtls_error, Qerror, "NSS unable to open socket: %s",
		      PR_ErrorToName (PR_GetError ()));
      return NULL;
    }

  /* Connect to the server */
  memset (&pr_addr, 0, sizeof (pr_addr));
  if (addr.addr.sa_family == AF_INET)
    {
      pr_addr.inet.family = AF_INET;
      pr_addr.inet.port = addr.addr4.sin_port;
      pr_addr.inet.ip = addr.addr4.sin_addr.s_addr;
    }
  else
    {
      pr_addr.ipv6.family = AF_INET6;
      pr_addr.ipv6.port = addr.addr6.sin6_port;
      pr_addr.ipv6.flowinfo = addr.addr6.sin6_flowinfo;
      memcpy (pr_addr.ipv6.ip.pr_s6_addr, addr.addr6.sin6_addr.s6_addr,
	      sizeof (pr_addr.ipv6.ip.pr_s6_addr));
      pr_addr.ipv6.scope_id = addr.addr6.sin6_scope_id;
    }

  if (PR_Connect (nspr->tls_file_desc, &pr_addr, PR_INTERVAL_NO_TIMEOUT)
		 != PR_SUCCESS)
    {
      if (PR_GetError () == PR_IN_PROGRESS_ERROR)
	{
	  PRPollDesc pollset[2];

	  pollset[0].in_flags = PR_POLL_WRITE | PR_POLL_EXCEPT;
	  pollset[0].out_flags = 0;
	  pollset[0].fd = nspr->tls_file_desc;
	  for (;;)
	    {
	      PRInt32 num_fds = PR_Poll (pollset, 1, PR_INTERVAL_NO_TIMEOUT);
	      if (num_fds < 0)
		{
		  PR_Close (nspr->tls_file_desc);
		  xfree (nspr);
		  warn_when_safe (Qtls_error, Qerror,
				  "NSS unable to connect: %s",
				  PR_ErrorToName (PR_GetError ()));
		  return NULL;
		}
	      if (PR_GetConnectStatus (pollset) == PR_SUCCESS)
		break;
	    }
	}
      else
	{
	  PR_Close (nspr->tls_file_desc);
	  xfree (nspr);
	  warn_when_safe (Qtls_error, Qerror, "NSS unable to connect: %s",
			  PR_ErrorToName (PR_GetError ()));
	  return NULL;
	}
    }

  /* Perform the handshake */
  if (SSL_ResetHandshake (nspr->tls_file_desc, PR_FALSE) != SECSuccess)
    {
      PR_Close (nspr->tls_file_desc);
      xfree (nspr);
      warn_when_safe (Qtls_error, Qerror, "NSS unable to reset handshake: %s",
		      PR_ErrorToName (PR_GetError ()));
      errno = EACCES;
      return NULL;
    }
  if (hostname != NULL &&
      SSL_SetURL (nspr->tls_file_desc, hostname) != SECSuccess)
    {
      PR_Close (nspr->tls_file_desc);
      xfree (nspr);
      warn_when_safe (Qtls_error, Qerror, "NSS unable to set URL (%s): %s",
		      hostname, PR_ErrorToName (PR_GetError ()));
      errno = EACCES;
      return NULL;
    }
  if (SSL_ForceHandshake (nspr->tls_file_desc) != SECSuccess)
    {
      PR_Close (nspr->tls_file_desc);
      xfree (nspr);
      warn_when_safe (Qtls_error, Qerror,
		      "NSS unable to complete handshake: %s",
		      PR_ErrorToName (PR_GetError ()));
      errno = EACCES;
      return NULL;
    }
  return nspr;
}

/* Set the key and certificate files to use */
static void
tls_set_x509_key_file (const Extbyte *certfile, const Extbyte *keyfile)
{
  Ascbyte name[sizeof ("PEM_Token ") + DECIMAL_PRINT_SIZE (EMACS_INT)];
  void *proto_win = NULL;
  PK11SlotInfo *slot = NULL;
  PK11GenericObject *obj;
  CERTCertificate *cert;
  CK_ATTRIBUTE attrs[4];
  CK_BBOOL cktrue = CK_TRUE, ckfalse = CK_FALSE;
  CK_OBJECT_CLASS objClass = CKO_PRIVATE_KEY;
  CK_SLOT_ID slot_id = nss_slot_count++;
  int retry_count = 0;

  /* Load the PEM module if it hasn't already been loaded */
  if (nss_pem_module == NULL)
    {
      nss_pem_module = SECMOD_LoadUserModule ((char *) "library=%s name=PEM parameters=\"\"", NULL, PR_FALSE);
      if (nss_pem_module == NULL)
	signal_error (Qtls_error, "Cannot find NSS PEM module", NSS_ERRSTR);
      if (!nss_pem_module->loaded)
	signal_error (Qtls_error, "Cannot load NSS PEM module", NSS_ERRSTR);
    }

  emacs_snprintf_ascbyte (name, sizeof (name), "PEM_Token %zd",
                          (EMACS_INT) slot_id);
  slot = PK11_FindSlotByName (name);
  if (slot == NULL)
    signal_error (Qtls_error, "Error finding NSS slot", NSS_ERRSTR);

  /* Set up the attributes for the keyfile */
  attrs[0].type = CKA_CLASS;
  attrs[0].pValue = &objClass;
  attrs[0].ulValueLen = sizeof (objClass);
  attrs[1].type = CKA_TOKEN;
  attrs[1].pValue = &cktrue;
  attrs[1].ulValueLen = sizeof (CK_BBOOL);
  attrs[2].type = CKA_LABEL;
  attrs[2].pValue = (void *) keyfile;
  attrs[2].ulValueLen = strlen (keyfile) + 1U;

  /* When adding an encrypted key, the PKCS#11 will be set as removed. */
  obj = PK11_CreateGenericObject (slot, attrs, 3, PR_FALSE);
  if (obj == NULL)
    {
      PR_SetError (SEC_ERROR_BAD_KEY, 0);
      signal_error (Qtls_error, "Bad key file", NSS_ERRSTR);
    }

  /* This will force the token to be seen as reinserted */
  SECMOD_WaitForAnyTokenEvent (nss_pem_module, 0, 0);
  PK11_IsPresent (slot);

  if (PK11_Authenticate (slot, PR_TRUE, &retry_count) != SECSuccess)
    signal_error (Qtls_error, "NSS: Unable to authenticate", NSS_ERRSTR);

  /* Set up the attributes for the certfile */
  objClass = CKO_CERTIFICATE;
  attrs[2].pValue = (void *) certfile;
  attrs[2].ulValueLen = strlen (certfile) + 1U;
  attrs[3].type = CKA_TRUST;
  attrs[3].pValue = &ckfalse;
  attrs[3].ulValueLen = sizeof (CK_BBOOL);

  obj = PK11_CreateGenericObject (slot, attrs, 4, PR_FALSE);
  PK11_FreeSlot (slot);
  if (obj == NULL)
    signal_error (Qtls_error, "Bad certificate file", NSS_ERRSTR);
  cert = PK11_FindCertFromNickname (name, proto_win);
  if (cert == NULL)
    signal_error (Qtls_error, "Cannot find certificate nickname", NSS_ERRSTR);
  CERT_DestroyCertificate (cert);
}

/* Function that gathers passwords for PKCS #11 tokens. */
static char *
nss_pk11_password (PK11SlotInfo *slot, PRBool retry, void * UNUSED (arg))
{
  Lisp_Object lsp_password;
  Extbyte *c_password, *nss_password;
  const Extbyte *token_name;
  Bytecount c_password_length;

  if (retry)
    return NULL;

  token_name = PK11_GetTokenName (slot);
  if (token_name == NULL)
    token_name = "security token";
  lsp_password =
    call1 (Qread_passwd, concat2 (prompt,
				    build_extstring (token_name, Qnative)));
  LISP_STRING_TO_SIZED_EXTERNAL (lsp_password, c_password, c_password_length,
                                 Qnative);
  nss_password = PL_strdup (c_password);

  /* Wipe out the password on the stack and in the Lisp string */
  memset (c_password, '*', c_password_length);
  Fclear_string (lsp_password);

  return nss_password;
}

void
init_tls (void)
{
  SECMODModule *module;

  /* Check that we are using compatible versions */
  if (PR_VersionCheck(PR_VERSION) == PR_FALSE)
    signal_error (Qinternal_error,
		  "NSPR version mismatch: expected " PR_VERSION, Qnil);
  if (NSS_VersionCheck(NSS_VERSION) == PR_FALSE)
    signal_error (Qinternal_error,
		  "NSS version mismatch: expected " NSS_VERSION, Qnil);

  /* Basic initialization of both libraries */
  PR_Init (PR_USER_THREAD, PR_PRIORITY_NORMAL, 0);
  if (NSS_Init ("sql:/etc/pki/nssdb") != SECSuccess)
    signal_error (Qtls_error, "Error initializing NSS", NSS_ERRSTR);

  /* Set the cipher suite policy */
  if (NSS_SetDomesticPolicy() != SECSuccess)
    signal_error (Qtls_error, "NSS unable to set policy", NSS_ERRSTR);

  /* Load the root certificates */
  module = SECMOD_LoadUserModule ((char *) "library=libnssckbi.so "
                                  "name=\"Root Certs\"", NULL, PR_FALSE);
  if (module == NULL || !module->loaded)
    signal_error (Qtls_error, "NSS unable to load root certificates",
		  NSS_ERRSTR);

  /* Setup password gathering */
  PK11_SetPasswordFunc (nss_pk11_password);

  /* Create the model file descriptors */
  nss_model = SSL_ImportFD (NULL, PR_OpenTCPSocket (PR_AF_INET));
  if (nss_model == NULL)
    {
      nss_model = SSL_ImportFD (NULL, PR_OpenTCPSocket (PR_AF_INET6));
      if (nss_model == NULL)
	signal_error (Qtls_error, "NSS cannot create model socket",
		      NSS_ERRSTR);
    }

  /* Set options on the model socket */
  if (SSL_OptionSet (nss_model, SSL_SECURITY, PR_TRUE) != SECSuccess)
    signal_error (Qtls_error, "NSS cannot enable model socket", NSS_ERRSTR);
#if NSS_VMAJOR < 3 || (NSS_VMAJOR == 3 && NSS_VMINOR < 24)
  if (SSL_OptionSet (nss_model, SSL_ENABLE_SSL2, PR_FALSE) != SECSuccess)
    signal_error (Qtls_error, "NSS unable to disable SSLv2", NSS_ERRSTR);
  if (SSL_OptionSet (nss_model, SSL_V2_COMPATIBLE_HELLO, PR_FALSE)
      != SECSuccess)
    signal_error (Qtls_error, "NSS unable to disable SSLv2 handshake",
		  NSS_ERRSTR);
#endif
  if (SSL_OptionSet (nss_model, SSL_ENABLE_DEFLATE, PR_FALSE) != SECSuccess)
    signal_error (Qtls_error, "NSS unable to disable deflate", NSS_ERRSTR);
  if (SSL_OptionSet (nss_model, SSL_HANDSHAKE_AS_CLIENT, PR_TRUE)
      != SECSuccess)
    signal_error (Qtls_error, "NSS unable to enable handshake as client",
		  NSS_ERRSTR);

  nss_inited = 1;
}
#endif /* HAVE_NSS */

#ifdef HAVE_GNUTLS
#include <gnutls/pkcs11.h>
#include <gnutls/x509.h>
#include "sysfile.h"

#define GNUTLS_ERRSTR(err) build_extstring (gnutls_strerror (err), Qnative)

/* The global credentials object */
static gnutls_certificate_credentials_t global_cred;

int
tls_get_fd (tls_state_t *state)
{
  return (int)(unsigned long)gnutls_transport_get_ptr (state->tls_session);
}

Bytecount
tls_read (tls_state_t *state, unsigned char *data, Bytecount size,
	  unsigned int allow_quit)
{
  ssize_t bytes;

 again:
  do
    {
      if (allow_quit)
	QUIT;
      bytes = gnutls_record_recv (state->tls_session, data, size);
    }
  while (bytes == GNUTLS_E_INTERRUPTED || bytes == GNUTLS_E_AGAIN);
  switch (bytes)
    {
    case GNUTLS_E_UNEXPECTED_PACKET_LENGTH:
      bytes = 0;
      break;
    case GNUTLS_E_REHANDSHAKE:
      {
	int err;

	do
	  err = gnutls_handshake (state->tls_session);
	while (err == GNUTLS_E_AGAIN || err == GNUTLS_E_INTERRUPTED);
	if (err == GNUTLS_E_SUCCESS)
	  goto again;
      }
      errno = EACCES;
      bytes = -1;
      break;
    default:
      if (bytes < 0 && errno == 0)
	{
	  errno = EPIPE;
	  bytes = -1;
	}
      break;
    }
  return (Bytecount) bytes;
}

Bytecount
tls_write (tls_state_t *state, const unsigned char *data, Bytecount size,
	   unsigned int allow_quit)
{
  ssize_t bytes;

  do
    {
      if (allow_quit)
	QUIT;
      bytes = gnutls_record_send (state->tls_session, data, size);
    }
  while (bytes == GNUTLS_E_INTERRUPTED || bytes == GNUTLS_E_AGAIN);
  if (bytes == GNUTLS_E_LARGE_PACKET)
    {
      errno = EMSGSIZE;
      bytes = -1;
    }
  else if (bytes < 0 && errno == 0)
    {
      errno = EPIPE;
      bytes = -1;
    }
  return (Bytecount) bytes;
}

int
tls_close (tls_state_t *state)
{
  if (--state->tls_refcount == 0)
    {
      int fd, err;

      fd = (int)(unsigned long)gnutls_transport_get_ptr (state->tls_session);
      gnutls_bye (state->tls_session, GNUTLS_SHUT_RDWR);
      err = retry_close (fd);
      gnutls_deinit (state->tls_session);
      xfree (state);
      return err;
     }
  return 0;
}

tls_state_t *
tls_open (int s, const Extbyte *hostname)
{
#ifndef HAVE_GNUTLS_CERTIFICATE_VERIFY_PEERS3
  gnutls_x509_crt_t cert;
#endif
  tls_state_t *gnutls;
  const char *errptr = NULL;
  const gnutls_datum_t *certs;
  unsigned int status, certslen = 0U;
  int err;
  const int val = 1;

  /* Disable Nagle's algorithm */
  setsockopt (s, IPPROTO_TCP, TCP_NODELAY, &val, sizeof(val));

  /* Create the state object */
  gnutls = (tls_state_t *) xmalloc (sizeof (*gnutls));
  gnutls->tls_refcount = 2;

  /* Initialize the session object */
  err = gnutls_init (&gnutls->tls_session, GNUTLS_CLIENT);
  if (err != GNUTLS_E_SUCCESS)
    {
      xfree (gnutls);
      warn_when_safe (Qtls_error, Qerror, "GNUTLS error in gnutls_init: %s",
		      gnutls_strerror (err));
      errno = EACCES;
      return NULL;
    }

  /* Configure the cipher preferences */
  err = gnutls_priority_set_direct (gnutls->tls_session, "NORMAL", &errptr);
  if (err != GNUTLS_E_SUCCESS)
    {
      xfree (gnutls);
      warn_when_safe (Qtls_error, Qerror,
		      "GNUTLS error in gnutls_priority_set_direct: %s at %s",
		      gnutls_strerror (err), errptr);
      errno = EACCES;
      return NULL;
    }

  /* Install the trusted certificates */
  err = gnutls_credentials_set (gnutls->tls_session, GNUTLS_CRD_CERTIFICATE,
				global_cred);
  if (err != GNUTLS_E_SUCCESS)
    {
      xfree (gnutls);
      warn_when_safe (Qtls_error, Qerror,
		      "GNUTLS error in gnutls_credentials_set: %s",
		      gnutls_strerror (err));
      errno = EACCES;
      return NULL;
    }

  /* Associate the socket with the session object */
  gnutls_transport_set_ptr (gnutls->tls_session,
			    (gnutls_transport_ptr_t)(unsigned long)s);

  /* Set the server name */
  if (hostname != NULL)
    {
      err = gnutls_server_name_set (gnutls->tls_session, GNUTLS_NAME_DNS,
				    hostname, strlen (hostname));
      if (err != GNUTLS_E_SUCCESS)
	{
	  xfree (gnutls);
	  warn_when_safe (Qtls_error, Qerror,
			  "GNUTLS error in gnutls_server_name_set: %s",
			  gnutls_strerror (err));
	  errno = EACCES;
	  return NULL;
	}
    }

  /* Perform the handshake */
  do
    err = gnutls_handshake (gnutls->tls_session);
  while (err == GNUTLS_E_AGAIN || err == GNUTLS_E_INTERRUPTED);
  if (err != GNUTLS_E_SUCCESS)
    {
      xfree (gnutls);
      warn_when_safe (Qtls_error, Qerror,
		      "GNUTLS error in gnutls_handshake: %s",
		      gnutls_strerror (err));
      errno = EACCES;
      return NULL;
    }

  /* Get the server certificate chain */
  certs = gnutls_certificate_get_peers (gnutls->tls_session, &certslen);
  if (certs == NULL || certslen == 0U)
    {
      xfree (gnutls);
      warn_when_safe (Qtls_error, Qerror,
		      "GNUTLS could not get peer certificate: %s",
		      gnutls_strerror (err));
      errno = EACCES;
      return NULL;
    }

  /* Validate the server certificate chain */
  status = (unsigned int) -1;
#ifdef HAVE_GNUTLS_CERTIFICATE_VERIFY_PEERS3
  if (hostname != NULL)
    err = gnutls_certificate_verify_peers3 (gnutls->tls_session, hostname,
					    &status);
  else
#endif /* HAVE_GNUTLS_CERTIFICATE_VERIFY_PEERS3 */
    err = gnutls_certificate_verify_peers2 (gnutls->tls_session, &status);
  if (err != GNUTLS_E_SUCCESS)
    {
      xfree (gnutls);
      warn_when_safe (Qtls_error, Qerror,
		      "GNUTLS could not verify peer certificate: %s",
		      gnutls_strerror (err));
      errno = EACCES;
      return NULL;
    }
  if (status != 0U)
    {
      gnutls_datum_t msg;

#ifdef HAVE_GNUTLS_CERTIFICATE_VERIFICATION_STATUS_PRINT
      gnutls_certificate_type_t type;

      type = gnutls_certificate_type_get (gnutls->tls_session);
      err =
	gnutls_certificate_verification_status_print (status, type, &msg, 0);
#else
      err = -1;
#endif /* HAVE_GNUTLS_CERTIFICATE_VERIFICATION_STATUS_PRINT */
      xfree (gnutls);
      if (err == 0)
	{
	  warn_when_safe (Qtls_error, Qerror,
			  "GNUTLS: certificate validation failed: %s",
			  msg.data);
	  gnutls_free(msg.data);
	  errno = EACCES;
	  return NULL;
	}
      else
	{
	  warn_when_safe (Qtls_error, Qerror,
			  "GNUTLS: certificate validation failed with code %u",
			  status);
	  errno = EACCES;
	  return NULL;
	}
    }

#ifndef HAVE_GNUTLS_CERTIFICATE_VERIFY_PEERS3
  if (hostname != NULL)
    {
      /* Match the peer certificate against the host name */
      err = gnutls_x509_crt_init (&cert);
      if (err != GNUTLS_E_SUCCESS)
	{
	  xfree (gnutls);
	  warn_when_safe (Qtls_error, Qerror,
			  "GNUTLS error in gnutls_x509_crt_init: %s",
			  gnutls_strerror (err));
	  errno = EACCES;
	  return NULL;
	}

      /* The peer certificate is the first certificate in the list */
      err = gnutls_x509_crt_import (cert, certs, GNUTLS_X509_FMT_DER);
      if (err != GNUTLS_E_SUCCESS)
	{
	  xfree (gnutls);
	  warn_when_safe (Qtls_error, Qerror,
			  "GNUTLS error in gnutls_x509_crt_import: %s",
			  gnutls_strerror (err));
	  gnutls_x509_crt_deinit (cert);
	  errno = EACCES;
	  return NULL;
	}

      err = gnutls_x509_crt_check_hostname (cert, hostname);
      if (err == 0)
	{
	  xfree (gnutls);
	  warn_when_safe (Qtls_error, Qerror,
			  "GNUTLS: hostname does not match certificate: %s",
			  gnutls_strerror (err));
	  gnutls_x509_crt_deinit (cert);
	  errno = EACCES;
	  return NULL;
	}
      gnutls_x509_crt_deinit (cert);
    }
#endif /* HAVE_GNUTLS_CERTIFICATE_VERIFY_PEERS3 */

  return gnutls;
}

/* Set the key and certificate files to use */
static void
tls_set_x509_key_file (const Extbyte *certfile, const Extbyte *keyfile)
{
  int err;

  err = gnutls_certificate_set_x509_key_file (global_cred, certfile, keyfile,
					      GNUTLS_X509_FMT_PEM);
  if (err < GNUTLS_E_SUCCESS)
    signal_error (Qtls_error, "gnutls_certificate_set_x509_key_file",
		  GNUTLS_ERRSTR (err));
}

/* Function that gathers PKCS #11 passwords. */
static int
gnutls_pk11_password (void * UNUSED (userdata), int UNUSED (attempt),
		      const char *token_url, const char *token_label,
		      unsigned int UNUSED (flags), char *pin, size_t pin_max)
{
  Lisp_Object lsp_password, args[5];
  Extbyte *c_password;
  size_t len;

  /* Get the password from the user */
  args[0] = prompt;
  args[1] = build_extstring (token_label, Qnative);
  args[2] = build_ascstring (" (");
  args[3] = build_extstring (token_url, Qnative);
  args[4] = build_ascstring (")");
  lsp_password = call1 (Qread_passwd, concatenate (5, args, Qstring, 0));
  c_password = LISP_STRING_TO_EXTERNAL (lsp_password, Qnative);

  /* Insert the password */
  len = strlen (c_password);
  if (len > pin_max)
    len = pin_max;
  memcpy (pin, c_password, len);
  pin[len] = '\0';

  /* Wipe out the password on the stack and in the Lisp string */
  memset (c_password, '*', strlen (c_password));
  Fclear_string (lsp_password);

  return GNUTLS_E_SUCCESS;
}

static void xfree_for_gnutls (void *ptr)
{
  /* GnuTLS sometimes tries to free NULL */
  if (ptr != NULL)
    xfree (ptr);
}

void
init_tls (void)
{
  int err = GNUTLS_E_SUCCESS;

  /* Tell gnutls to use our memory allocation functions */
  gnutls_global_set_mem_functions ((void * (*)(size_t)) xmalloc,
				   (void * (*)(size_t)) xmalloc,
				   NULL,
				   (void * (*)(void *, size_t)) xrealloc,
				   xfree_for_gnutls);

  /* Initialize the library */
  err = gnutls_global_init ();
  if (err != GNUTLS_E_SUCCESS)
    signal_error (Qtls_error, "gnutls_global_init", GNUTLS_ERRSTR (err));

  /* Load the trusted CA certificates */
  err = gnutls_certificate_allocate_credentials (&global_cred);
  if (err != GNUTLS_E_SUCCESS)
    signal_error (Qtls_error, "gnutls_certificate_allocate_credentials",
		  GNUTLS_ERRSTR (err));
  err = gnutls_certificate_set_x509_system_trust (global_cred);
  if (err == 0)
    signal_error (Qtls_error, "gnutls: no system certificates found", Qnil);
  if (err < 0)
    signal_error (Qtls_error, "gnutls_certificate_set_x509_system_trust",
		  GNUTLS_ERRSTR (err));

  /* Setup password gathering */
  gnutls_pkcs11_set_pin_function (gnutls_pk11_password, NULL);
}
#endif /* HAVE_GNUTLS */

#ifdef HAVE_OPENSSL
#include <unistd.h>
#include <openssl/conf.h>
#include <openssl/err.h>

#ifdef HAVE_X509_CHECK_HOST
#include <openssl/x509v3.h>
#endif

/* If ERR_clear_error() isn't called before every operation that can fail OR
   ERR_get_error() isn't called after every failed operation, there will be
   stale leftover entries in the per-thread error queue - in our case, the one
   and only error queue - and the error handling will start giving wrong
   reasons for failures. This also affects the OpenSSL bignum support in
   number-openssl.c.

   The error handling API does, like the great Ben Wing likes to say, FMH. An
   easy solution is to add these wrapper macros. When extending this API,
   please adhere to the convention that ERR_clear_error() is called before a
   call that uses the error handling mechanism.

   See

   https://stackoverflow.com/questions/18179128/how-to-manage-the-error-queue-in-openssl-ssl-get-error-and-err-get-error
   https://www.freebsd.org/cgi/man.cgi?query=SSL_get_error&apropos=0&sektion=3&manpath=FreeBSD+13.1-RELEASE&arch=default&format=html
   https://www.freebsd.org/cgi/man.cgi?query=ERR_get_error&apropos=0&sektion=3&manpath=FreeBSD+13.1-RELEASE&arch=default&format=html

   for further details.

   03.06.2022 -Jaakko Salomaa */
#define SSL_connect(p)  (ERR_clear_error (), SSL_connect p)
#define SSL_CTX_new(p)  (ERR_clear_error (), SSL_CTX_new p)
#define SSL_CTX_set_cipher_list(p)                                            \
  (ERR_clear_error (), SSL_CTX_set_cipher_list p)
#define SSL_CTX_set_default_verify_paths(p)                                   \
  (ERR_clear_error (), SSL_CTX_set_default_verify_paths p)
#define SSL_CTX_use_certificate_file(p)                                       \
  (ERR_clear_error (), SSL_CTX_use_certificate_file p)
#define SSL_CTX_use_PrivateKey_file(p)                                        \
  (ERR_clear_error (), SSL_CTX_use_PrivateKey_file p)
#define SSL_new(p)      (ERR_clear_error (), SSL_new p)
#define SSL_read(p)     (ERR_clear_error (), SSL_read p)
#define SSL_set_fd(p)   (ERR_clear_error (), SSL_set_fd p)
#define SSL_set_tlsext_host_name_xe(p)                                        \
  (ERR_clear_error (), SSL_set_tlsext_host_name p)
#define SSL_shutdown(p) (ERR_clear_error (), SSL_shutdown p)
#define SSL_write(p)    (ERR_clear_error (), SSL_write p)

/* The context used to create connections */
static SSL_CTX *ssl_ctx;

static Lisp_Object
openssl_error_string (void)
{
  Lisp_Object args[3];
  unsigned long err = ERR_get_error ();

  args[0] = build_ascstring (ERR_lib_error_string (err));
  args[1] = build_ascstring (":");
  args[2] = build_ascstring (ERR_reason_error_string (err));
  return concatenate (countof (args), args, Qstring, 0);
}

static unsigned long
openssl_report_error_stack (const char *msg, const SSL *ssl)
{
  unsigned long err = ERR_get_error ();
  if (err > 0UL)
    {
      if (ERR_GET_LIB (err) == ERR_LIB_SSL &&
	  ERR_GET_REASON (err) == SSL_R_CERTIFICATE_VERIFY_FAILED)
	{
	  long cert_err = SSL_get_verify_result (ssl);
	  warn_when_safe (Qtls_error, Qerror, "%s:%s", msg,
			  X509_verify_cert_error_string (cert_err));
	}
      else
	{
	  const char *lib = ERR_lib_error_string (err);
	  const char *reason = ERR_reason_error_string (err);
	  warn_when_safe (Qtls_error, Qerror, "%s:%s:%s", msg,
			  lib == NULL ? "<unknown>" : lib,
			  reason == NULL ? "<unknown>" : reason);
	}
    }
  return err;
}

/* Return values:
 * -1 = fatal error, caller should exit
 *  0 = no error, caller should continue
 *  1 = nonfatal error, caller should retry
 */
static int
openssl_report_error_num (const char *msg, const SSL *ssl, int ret, int retry)
{
  int errno_copy = errno;
  int ssl_error = SSL_get_error (ssl, ret);
  int err;

  switch (ssl_error)
    {
    case SSL_ERROR_NONE:
    case SSL_ERROR_ZERO_RETURN:
      err = 0;
      break;
    case SSL_ERROR_WANT_READ:
    case SSL_ERROR_WANT_WRITE:
      err = retry;
      break;
    case SSL_ERROR_WANT_CONNECT:
    case SSL_ERROR_WANT_ACCEPT:
    case SSL_ERROR_WANT_X509_LOOKUP:
      err = 1;
      break;
    case SSL_ERROR_SYSCALL:
      if (openssl_report_error_stack (msg, ssl) == 0UL && ret < 0)
	warn_when_safe (Qtls_error, Qerror, "%s: %s", msg,
			strerror (errno_copy));
      err = ret;
      break;
    case SSL_ERROR_SSL:
      openssl_report_error_stack (msg, ssl);
      err = -1;
      break;
    default:
      warn_when_safe (Qtls_error, Qerror, "%s: error %d", msg, ssl_error);
      err = -1;
      break;
    }
  errno = errno_copy;
  return err;
}

int
tls_get_fd (tls_state_t *state)
{
  return SSL_get_fd (state->tls_connection);
}

Bytecount
tls_read (tls_state_t *state, unsigned char *data, Bytecount size,
	  unsigned int allow_quit)
{
  int action, bytes;

  if (SSL_get_shutdown (state->tls_connection))
    return 0;

  bytes = SSL_read ((state->tls_connection, data, size));
  action = (bytes > 0) ? 0
    : openssl_report_error_num ("SSL_read", state->tls_connection, bytes, 0);
  while (bytes <= 0 && action > 0)
    {
      if (allow_quit)
	QUIT;
      bytes = SSL_read ((state->tls_connection, data, size));
      action = (bytes > 0) ? 0
	: openssl_report_error_num ("SSL_read", state->tls_connection,
				    bytes, 0);
    }
  return (Bytecount) bytes;
}

Bytecount
tls_write (tls_state_t *state, const unsigned char *data, Bytecount size,
	   unsigned int allow_quit)
{
  int action, bytes;

  if (SSL_get_shutdown (state->tls_connection))
    return 0;

  bytes = SSL_write ((state->tls_connection, data, size));
  action = (bytes > 0) ? 0
    : openssl_report_error_num ("SSL_write", state->tls_connection, bytes, 0);
  while (bytes <= 0 && action > 0)
    {
      if (allow_quit)
	QUIT;
      bytes = SSL_write ((state->tls_connection, data, size));
      action = (bytes > 0) ? 0
	: openssl_report_error_num ("SSL_write", state->tls_connection,
				    bytes, 0);
    }
  return (Bytecount) bytes;
}

int
tls_close (tls_state_t *state)
{
  if (--state->tls_refcount == 0)
    {
      int err, fd;

      fd = SSL_get_fd (state->tls_connection);
      if (SSL_get_shutdown (state->tls_connection) == 0)
	{
          err = SSL_shutdown ((state->tls_connection));
	  if (err < 0 && errno == EBADF)
	    err = 0;
	  if (err < 0)
	    openssl_report_error_num ("SSL_shutdown failed",
				      state->tls_connection, err, 0);
	}
      else
	{
	  err = 0;
	}
      close (fd);
      SSL_free (state->tls_connection);
      xfree (state);
      return err > 0 ? 0 : err;
     }
  return 0;
}

tls_state_t *
tls_open (int s, const Extbyte *hostname)
{
  tls_state_t *openssl;
  X509 *peer_cert = NULL;
  const int val = 1;
  int err;
  long cert_err;

  /* Disable Nagle's algorithm */
  setsockopt (s, IPPROTO_TCP, TCP_NODELAY, &val, sizeof(val));

  /* Create the state object */
  openssl = (tls_state_t *) xmalloc (sizeof (*openssl));
  openssl->tls_refcount = 2;

  /* Create the connection object */
  openssl->tls_connection = SSL_new ((ssl_ctx));
  if (openssl->tls_connection == NULL)
    {
      openssl_report_error_stack ("SSL_new failed", NULL);
      goto error;
    }
  if (SSL_set_fd ((openssl->tls_connection, s)) == 0)
    {
      openssl_report_error_stack ("SSL_set_fd", openssl->tls_connection);
      goto error;
    }

  /* Enable the ServerNameIndication extension */
  if (hostname != NULL &&
      !SSL_set_tlsext_host_name_xe ((openssl->tls_connection, hostname)))
    {
      openssl_report_error_stack ("SSL_set_tlsext_host_name failed",
				  openssl->tls_connection);
      goto error;
    }

  /* Perform the handshake */
  err = SSL_connect ((openssl->tls_connection));
  while (err != 1)
    {
      int action = openssl_report_error_num ("SSL_connect failed",
					     openssl->tls_connection, err, 1);
      if (action < 0)
	goto error;
      err = SSL_connect ((openssl->tls_connection));
    }

  /* Get the server certificate */
  peer_cert = SSL_get_peer_certificate (openssl->tls_connection);
  if (peer_cert == NULL)
    {
      warn_when_safe (Qtls_error, Qerror,
		      "Peer did not present a certificate");
      goto error;
    }

  cert_err = SSL_get_verify_result (openssl->tls_connection);
  if (cert_err != X509_V_OK)
    {
      warn_when_safe (Qtls_error, Qerror,
		      "Peer certificate verification failure:%s",
		      X509_verify_cert_error_string (cert_err));
      goto error;
    }

#ifdef HAVE_X509_CHECK_HOST
  err = X509_check_host (peer_cert, (const char *) hostname,
			 strlen (hostname), 0, NULL);
  if (err < 0)
    {
      warn_when_safe (Qtls_error, Qerror,
		      "Out of memory while checking certificate");
      goto error;
    }
  if (err == 0)
    {
      warn_when_safe (Qtls_error, Qerror,
		      "Peer certificate verification failure");
      goto error;
    }
#endif
  X509_free (peer_cert);

  return openssl;

 error:
  if (openssl->tls_connection != NULL)
    SSL_free (openssl->tls_connection);
  xfree (openssl);
  errno = EACCES;
  return NULL;
}

/* Set the key and certificate files to use */
static void
tls_set_x509_key_file (const Extbyte *certfile, const Extbyte *keyfile)
{
  int err;

  err = SSL_CTX_use_PrivateKey_file ((ssl_ctx, keyfile, SSL_FILETYPE_PEM));
  if (err <= 0)
    signal_error (Qtls_error, "SSL_CTX_use_PrivateKey_file",
		  openssl_error_string ());
  err = SSL_CTX_use_certificate_file ((ssl_ctx, certfile, SSL_FILETYPE_PEM));
  if (err <= 0)
    signal_error (Qtls_error, "SSL_CTX_use_certificate_file",
		  openssl_error_string ());
}

/* Function that gathers passwords for PKCS #11 tokens. */
static int
openssl_password (char *buf, int size, int UNUSED (rwflag),
		  void *UNUSED (userdata))
{
  Lisp_Object lsp_password;
  Extbyte *c_password;
  Bytecount c_password_length, copy_length;

  lsp_password =
    call1 (Qread_passwd, concat2 (prompt, build_ascstring ("PEM: ")));
  LISP_STRING_TO_SIZED_EXTERNAL (lsp_password, c_password, c_password_length,
                                 Qnative);
  copy_length = min (c_password_length, (Bytecount) size - 1);
  memcpy (buf, c_password, copy_length);
  buf[copy_length] = '\0';

  /* Wipe out the password on the stack and in the Lisp string */
  memset (c_password, '*', c_password_length);
  Fclear_string (lsp_password);

  return (int) copy_length;
}

#if OPENSSL_VERSION_NUMBER >= 0x1010000fL
static void *
openssl_malloc (size_t size, const char * UNUSED (file), int UNUSED (line))
{
  return xmalloc (size);
}

static void *
openssl_realloc (void *ptr, size_t size, const char * UNUSED (file),
		 int UNUSED (line))
{
  return xrealloc (ptr, size);
}

static void
openssl_free (void *ptr, const char * UNUSED (file), int UNUSED (line))
{
  xfree (ptr);
}
#endif

void
init_tls (void)
{
#if OPENSSL_VERSION_NUMBER >= 0x1010000fL
  /* Load the default configuration */
  OPENSSL_init_ssl (OPENSSL_INIT_LOAD_SSL_STRINGS |
		    OPENSSL_INIT_LOAD_CONFIG |
		    OPENSSL_INIT_LOAD_CRYPTO_STRINGS,
		    NULL);

  /* Tell openssl to use our memory allocation functions */
  CRYPTO_set_mem_functions (openssl_malloc, openssl_realloc, openssl_free );
#else
  /* Load the default configuration */
  OPENSSL_config (NULL);

  /* Tell openssl to use our memory allocation functions */
  CRYPTO_set_mem_functions ((void * (*)(size_t)) xmalloc,
			    (void * (*)(void *, size_t)) xrealloc,
			    xfree_1);

  /* Load human-readable error messages */
  SSL_load_error_strings ();

  /* Initialize the library */
  SSL_library_init ();
#endif

  /* Configure a client connection context, and send a handshake for the
   * highest supported TLS version. */
  ssl_ctx = SSL_CTX_new ((SSLv23_client_method ()));
  if (ssl_ctx == NULL)
    signal_error (Qtls_error, "SSL_CTX_new failed", openssl_error_string ());

  /* Disallow SSLv2 and disable compression. */
  SSL_CTX_set_options (ssl_ctx, SSL_OP_NO_SSLv2 | SSL_OP_NO_COMPRESSION);

  /* Set various useful mode bits */
  SSL_CTX_set_mode (ssl_ctx, SSL_MODE_ENABLE_PARTIAL_WRITE |
		    SSL_MODE_AUTO_RETRY | SSL_MODE_RELEASE_BUFFERS);

  /* Let the system select the ciphers */
  if (SSL_CTX_set_cipher_list ((ssl_ctx, "DEFAULT")) != 1)
    signal_error (Qtls_error, "SSL_CTX_set_cipher_list failed",
		  openssl_error_string ());

  /* Load the set of trusted root certificates. */
  if (!SSL_CTX_set_default_verify_paths ((ssl_ctx)))
    signal_error (Qtls_error, "SSL_CTX_set_default_verify_paths failed",
		  openssl_error_string ());

  /* Setup password gathering */
  SSL_CTX_set_default_passwd_cb (ssl_ctx, openssl_password);
}
#endif /* HAVE_OPENSSL */

#ifdef WITH_TLS
tls_state_t *
tls_negotiate (int fd, const Extbyte *host, Lisp_Object keylist)
{
  EXTERNAL_LIST_LOOP_2 (elt, keylist)
    {
      Lisp_Object keyfile = Fcar (elt);
      Lisp_Object certfile = Fcar (Fcdr (elt));
      Extbyte *c_keyfile, *c_certfile;

      if (!STRINGP (keyfile))
	invalid_argument ("Keyfile must be a filename", keyfile);
      if (!STRINGP (certfile))
	invalid_argument ("Certfile must be a filename", certfile);

      c_keyfile = LISP_STRING_TO_EXTERNAL (keyfile, Qfile_name);
      c_certfile = LISP_STRING_TO_EXTERNAL (certfile, Qfile_name);
      tls_set_x509_key_file (c_certfile, c_keyfile);
    }
  return tls_open (fd, host);
}
#endif /* WITH_TLS */

#ifndef WITH_TLS
void
init_tls (void)
{
}
#endif /* !WITH_TLS */

void
syms_of_tls (void)
{
#ifdef WITH_TLS
  DEFSYMBOL (Qread_passwd);
#endif
}

void
vars_of_tls (void)
{
#ifdef WITH_TLS
  staticpro (&prompt);
  prompt = build_ascstring ("Password for ");
  Fprovide (intern ("tls"));
#ifdef HAVE_NSS
  Fprovide (intern ("tls-nss"));
#endif
#ifdef HAVE_GNUTLS
  Fprovide (intern ("tls-gnutls"));
#endif
#ifdef HAVE_OPENSSL
  Fprovide (intern ("tls-openssl"));
#endif
#endif
}
