;; ALPN testing for Emacs v31   -*- lexical-binding: t -*-
;;
;; Author: Eric Marsden <eric.marsden@risk-engineering.org>
;;
;; Perhaps a little inconsistent: if server is not configured to check ALPN, sending ALPN does not
;; lead to failure. If server is looking for ALPN and chooses another one, connection fails.

(require 'gnutls)

(defvar alpn-port 8881)
(defvar alpn-protocol "foobles")


(defun alpn-setup-certs ()
  (let* ((certdir (expand-file-name "certs" temporary-file-directory))
         (_ (make-directory certdir t))
         (default-directory certdir))
    (shell-command (concat "openssl req -new -nodes -text -out root.csr "
                               "-keyout root.key -subj '/CN=localhost'"))
    (set-file-modes "root.key" #o600)
    (shell-command (concat "openssl x509 -req -in root.csr -text -days 42 "
                               "-extfile /etc/ssl/openssl.cnf -extensions v3_ca "
                               "-signkey root.key -out root.crt"))
    (shell-command (concat "openssl req -new -nodes -text -out server.csr "
                               "-keyout server.key -subj '/CN=localhost'"))
    (set-file-modes "server.key" #o600)
    (shell-command (concat "openssl x509 -req -in server.csr -text -days 42 "
                               "-CA root.crt -CAkey root.key "
                               "-CAcreateserial -out server.crt"))
    (shell-command (concat "openssl req -new -nodes -out client.csr -keyout client.key "
                               "-subj '/CN=emacs'"))
    (shell-command (concat "openssl x509 -req -days 42 -in client.csr "
                               "-CA root.crt -CAkey root.key "
                               "-CAcreateserial -out client.crt"))
    certdir))

(defun alpn-setup/openssl (certdir)
  (let* ((cmd (format "openssl s_server -rev -port %d -cert %s -key %s -debug -alpn %s"
                      alpn-port
                      (expand-file-name "server.crt" certdir)
                      (expand-file-name "server.key" certdir)
                      alpn-protocol))
         (buf (get-buffer-create "*OpenSSL*")))
    (start-process-shell-command "openssl" buf cmd)))

(defun alpn-setup/rustls (certdir)
  (let* ((cargo (expand-file-name ".cargo/bin/cargo" (getenv "HOME")))
         (cmd (format "%s run --bin tlsserver-mio -- --port %d --certs %s --key %s --proto %s echo"
                      cargo
                      alpn-port
                      (expand-file-name "server.crt" certdir)
                      (expand-file-name "server.key" certdir)
                      alpn-protocol))
         (buf (get-buffer-create "*Rustls*"))
         ;; clone of https://github.com/rustls/rustls.git
         (default-directory "/tmp/rustls"))
    (start-process-shell-command "rustls" buf cmd)))

(defun alpn-fetch (certdir)
  (let* ((buf (generate-new-buffer " *ALPN*"))
         (process (open-network-stream "alpn" buf "localhost" alpn-port))
         (gnutls-log-level 2))
    (gnutls-negotiate :process process
                      :hostname "localhost"
                      :alpn-protocols (list alpn-protocol)
                      :trustfiles (list (expand-file-name "root.crt" certdir)))
    (process-send-string process "bizzles\n")
    (accept-process-output process 0.1)
    (with-current-buffer buf (buffer-string))))

(defun alpn-test-openssl ()
  (let ((certdir (alpn-setup-certs)))
    (alpn-setup/openssl certdir)
    (sleep-for 1)
    (message "ALPN> %s" (alpn-fetch certdir))))

(defun alpn-test-rustls ()
  (let ((certdir (alpn-setup-certs)))
    (alpn-setup/rustls certdir)
    (sleep-for 1)
    (message "ALPN> %s" (alpn-fetch certdir))))