[elpa] externals/crdt 932566653e 23/44: TLS support by stunnel.

[ELPA Syncer]

branch: externals/crdt
commit 932566653ee2c2e03a22cff018590e9b95e1eeaf
Author: Qiantan Hong <qhong@alum.mit.edu>
Commit: Qiantan Hong <qhong@alum.mit.edu>

    TLS support by stunnel.
---
 crdt.el | 193 +++++++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 143 insertions(+), 50 deletions(-)

diff --git a/crdt.el b/crdt.el
index c25dfed32e..b92ded9422 100644
--- a/crdt.el
+++ b/crdt.el
@@ -76,6 +76,26 @@
   "Start tuntox proxy for CRDT servers."
   :type '(choice boolean (const confirm)))
 
+(defcustom crdt-stunnel-executable "stunnel"
+  "Path to the stunnel binary."
+  :type 'file)
+
+(defcustom crdt-tls-certificate
+  (concat (file-name-as-directory (if (featurep 'xdg) (xdg-data-home) "~/"))
+          "crdt-tls.pem")
+  "Path to TLS certificate file used for TLS-secured server."
+  :type 'file)
+
+(defcustom crdt-tls-private-key
+  (concat (file-name-as-directory (if (featurep 'xdg) (xdg-data-home) "~/"))
+          "crdt-tls-key.pem")
+  "Path to TLS private key file used for TLS-secured server."
+  :type 'file)
+
+(defcustom crdt-use-stunnel t
+  "Start stunnel proxy for CRDT servers."
+  :type '(choice boolean (const confirm)))
+
 (defcustom crdt-read-settings-help-string
   (concat "\\[forms-next-field]:Next Field, \\[forms-prev-field]:Prev Field\n"
           "\\[forms-next-record]:History Next, \\[forms-prev-record]:History 
Prev\n"
@@ -2144,6 +2164,7 @@ Create a new one if such a CRDT session doesn't exist."
                 (crdt-read-settings
                  (format "*Settings for %s*" session-name)
                  `(("Port: " "6530" ,(crdt--settings-make-ensure-type 
'numberp))
+                   ("Secure Port: " "6540" ,(crdt--settings-make-ensure-type 
'numberp))
                    ("Session Name: " ,session-name 
,(crdt--settings-make-ensure-nonempty session-name))
                    ("Password: " "")
                    ("Display Name: " ,crdt-default-name)
@@ -2164,9 +2185,59 @@ Create a new one if such a CRDT session doesn't exist."
           (message "Only server can stop sharing a buffer.")))
     (message "Not a CRDT shared buffer.")))
 
+(defun crdt-generate-certificate (save-path &optional certtool-executable 
log-file)
+  "Generate a self-signed certificate with private key.
+Store the .pem file to SAVE-PATH.  If CERTTOOL-EXECUTABLE is
+provided, it should be a path to a GnuTLS executable, which will
+be used.  Otherwise, search for gnutls-certtool, then certtool,
+in (EXEC-PATH).  Write diagnostic outputs to LOG-FILE.  If
+LOG-FILE is nil, append .log to SAVE-PATH and use that instead."
+  (setq save-path (expand-file-name save-path))
+  (setq log-file
+        (if log-file (expand-file-name log-file)
+          (concat save-path ".log")))
+  (unless certtool-executable
+    (setq certtool-executable
+          (or (locate-file "gnutls-certtool" (exec-path) exec-suffixes 1)
+              (locate-file "certtool" (exec-path) exec-suffixes 1))))
+  (unless certtool-executable
+    (signal 'file-error "Cannot locate GnuTLS certificate tool executable."))
+  (with-temp-file save-path
+    (let ((save-buffer (current-buffer)))
+      (unless (= 0 (call-process certtool-executable nil (list save-buffer 
log-file) nil "-p"))
+        (error "Failed to generate private key"))
+      (write-region nil nil save-path)
+      (with-temp-buffer
+        (insert "tls_www_server")
+        (unless (= 0 (call-process-region
+                      nil nil certtool-executable nil (list save-buffer 
log-file) nil
+                      "-s" "--load-privkey" save-path "--template=/dev/stdin"))
+          (error "Failed to generate certificate"))))))
+
+(defun crdt-start-stunnel (port secure-port)
+  "Start a stunnel proxy that forwards SECURE-PORT to PORT.
+Return the stunnel proxy process."
+  (unless (file-exists-p crdt-tls-certificate)
+    (if (yes-or-no-p (format "%s does not exist. Generate a self-signing 
certificate? "
+                             crdt-tls-certificate))
+        (crdt-generate-certificate crdt-tls-certificate)
+      (error "TLS certificate %s does not exist" crdt-tls-certificate)))
+  (let ((stunnel-process
+         (make-process :name "Stunnel Proxy"
+                       :buffer (generate-new-buffer "*Stunnel Proxy*")
+                       :command '("stunnel" "/dev/stdin"))))
+    (display-buffer (process-buffer stunnel-process))
+    (process-send-string stunnel-process
+                         (format 
"foreground=yes\ncert=%s\nkey=%s\n[ein]\naccept=%d\nconnect=%d\n"
+                                 crdt-tls-certificate crdt-tls-certificate 
secure-port port))
+    (process-send-eof stunnel-process)
+    stunnel-process))
+
 (defun crdt-new-session
-    (port session-name password display-name permissions)
+    (port secure-port session-name password display-name permissions)
   "Start a new CRDT session on PORT with SESSION-NAME.
+When CRDT-USE-STUNNEL is non nil, also start a stunnel proxy on SECURE-PORT,
+otherwise SECURE-PORT is ignored.
 Setup up the server with PASSWORD and assign this Emacs DISPLAY-NAME.
 PERMISSIONS is a list that describes policies
 for public session-scoped functionss.
@@ -2199,7 +2270,7 @@ Each element should be one of
                             (yes-or-no-p "Start a tuntox proxy for this 
session? ")))))
     (process-put network-process 'crdt-session new-session)
     (push new-session crdt--session-list)
-    (if tuntox-p
+    (if tuntox-p ; TODO: factor this out like `crdt-start-stunnel'
         (let ((proxy-process
                (make-process :name "Tuntox Proxy"
                              :buffer (generate-new-buffer "*Tuntox Proxy*")
@@ -2209,12 +2280,16 @@ Each element should be one of
                                "-f" "/dev/stdin" ; do the filtering for safety 
sake
                                ,@ (when (and password (> (length password) 0))
                                     `("-s" ,password))))))
+          (display-buffer (process-buffer proxy-process))
           (process-put network-process 'tuntox-process proxy-process)
           (process-send-string proxy-process (format "127.0.0.1:%s\n" port)) ; 
only allow connection to our port
-          (process-send-eof proxy-process)
-          (switch-to-buffer-other-window (process-buffer proxy-process)))
+          (process-send-eof proxy-process))
       (when (and password (> (length password) 0))
         (process-put network-process 'password password)))
+    (when crdt-use-stunnel
+      (condition-case c
+          (process-put network-process 'stunnel-process (crdt-start-stunnel 
port secure-port))
+        (error (warn "Stunnel proxy not started: %s" c))))
     new-session))
 
 (defun crdt--stop-session (session)
@@ -2245,13 +2320,14 @@ Each element should be one of
           (delq session crdt--session-list))
     (crdt--refresh-sessions-maybe)
     (let* ((process (crdt--session-network-process session))
-           (proxy-process (process-get process 'tuntox-process))
            (process-buffer (process-buffer process)))
       (delete-process (crdt--session-network-process session))
       (when (and process-buffer (buffer-live-p process-buffer))
         (kill-buffer process-buffer))
-      (when (and proxy-process (process-live-p proxy-process))
-        (interrupt-process proxy-process)))
+      (dolist (proxy-process (list (process-get process 'tuntox-process)
+                                   (process-get process 'stunnel-process)))
+        (when (and proxy-process (process-live-p proxy-process))
+          (interrupt-process proxy-process))))
     (unless (memq this-command '(crdt-disconnect crdt-stop-session 
crdt--stop-session))
       (warn "CRDT session %s disconnected." (crdt--session-name session)))))
 
@@ -2301,56 +2377,71 @@ Join with DISPLAY-NAME."
   (interactive
    (crdt-read-settings
     "*CRDT Connect Settings*"
-    `(("URL: " ":6530" ,(lambda (url)
+    `(("URL: " "" ,(lambda (url)
                    (let (parsed-url)
                      (when (eq (length url) 0)
                        (error "Please input a valid URL"))
                      (setq parsed-url (url-generic-parse-url url))
                      (when (or (not (url-type parsed-url))
                                (string-equal (url-type parsed-url) 
"localhost")) ; for ease of local debugging
-                       (setq parsed-url (url-generic-parse-url (concat 
"tcp://" url))))
-                     (when (and (not (url-portspec parsed-url)) (member 
(url-type parsed-url) '("tcp" "tuntox")))
-                       (let ((port (read-from-minibuffer "Server port (default 
6530): " nil nil t nil "6530")))
-                         (unless (numberp port)
-                           (error "Port must be a number"))
-                         (setf (url-portspec parsed-url) port)))
+                       (setq parsed-url (url-generic-parse-url (concat 
"eins://" url))))
+                     (when (not (url-portspec parsed-url))
+                       (pcase (url-type parsed-url)
+                         ("eins" (setf (url-portspec parsed-url) 6540))
+                         ("ein" (setf (url-portspec parsed-url) 6530))
+                         ("tuntox" (setf (url-portspec parsed-url) 6530))))
                      parsed-url)))
       ("Display Name: " ,crdt-default-name 
,(crdt--settings-make-ensure-nonempty crdt-default-name)))))
-  (let ((url-type (url-type url))
-        address port)
-    (cl-macrolet ((start-session (&body body)
-                    `(let* ((network-process (make-network-process
-                                              :name "CRDT Client"
-                                              :buffer (generate-new-buffer " 
*crdt-client*")
-                                              :host address
-                                              :service port
-                                              :filter #'crdt--network-filter
-                                              :sentinel 
#'crdt--client-process-sentinel))
-                            (name-placeholder (format "%s:%s" address port))
-                            (new-session
-                             (crdt--make-session :local-clock 0
-                                                 :local-name display-name
-                                                 :name name-placeholder
-                                                 :network-process 
network-process)))
-                      (process-put network-process 'crdt-session new-session)
-                      (push new-session crdt--session-list)
-                      ,@body
-                      (process-send-string
-                       network-process
-                       (crdt--format-message
-                        `(hello ,(crdt--session-local-name new-session) 
,crdt-protocol-version)))
-                      (let ((crdt--session new-session))
-                        (crdt-list-buffers)))))
-      (cond ((equal url-type "tcp")
-             (setq address (url-host url))
-             (setq port (url-portspec url))
-             (start-session))
+  (let ((url-type (url-type url)))
+    (cl-flet ((start-session (&rest process-args)
+                (let* ((network-process (apply #'make-network-process
+                                               :name "CRDT Client"
+                                               :buffer (generate-new-buffer " 
*crdt-client*")
+                                               :filter #'crdt--network-filter
+                                               :sentinel 
#'crdt--client-process-sentinel
+                                               process-args))
+                       (name-placeholder (url-recreate-url url))
+                       (new-session
+                        (crdt--make-session :local-clock 0
+                                            :local-name display-name
+                                            :name name-placeholder
+                                            :network-process network-process)))
+                  (process-put network-process 'crdt-session new-session)
+                  (push new-session crdt--session-list)
+                  (process-send-string
+                   network-process
+                   (crdt--format-message
+                    `(hello ,(crdt--session-local-name new-session) 
,crdt-protocol-version)))
+                  (let ((crdt--session new-session))
+                    (crdt-list-buffers))
+                  network-process)))
+      (cond ((equal url-type "ein")
+             (start-session :host (url-host url) :service (url-portspec url)))
+            ((equal url-type "eins")
+             (condition-case c
+                 (let ((proc
+                        (start-session :host (url-host url) :service 
(url-portspec url)
+                                       :tls-parameters
+                                       (cons 'gnutls-x509pki
+                                             (gnutls-boot-parameters
+                                              :type 'gnutls-x509pki
+                                              :hostname (url-host url))))))
+                   (message "%s" (process-status proc))
+                   (unless (eq (process-status proc) 'open)
+                     (signal 'file-error "Failed to establish TLS 
connection."))
+                   proc)
+               (file-error
+                (if (not (= (url-portspec url) 6540))
+                    (signal (car c) (cdr c))
+                  (let ((old-url-string (url-recreate-url url)))
+                    (setf (url-portspec url) 6530 (url-type url) "ein")
+                    (warn "Failed to connect to %s, falling back to %s" 
old-url-string (url-recreate-url url))
+                    (start-session :host (url-host url) :service (url-portspec 
url)))))))
             ((equal url-type "tuntox")
-             (setq address "127.0.0.1")
-             (setq port (read-from-minibuffer (format "tuntox proxy port 
(default %s): "
-                                                      (1+ (url-portspec url)))
-                                              nil nil t nil (format "%s" (1+ 
(url-portspec url)))))
-             (let ((password (read-passwd "tuntox password (empty for no 
password): ")))
+             (let ((port (read-from-minibuffer (format "tuntox proxy port 
(default %s): "
+                                                       (1+ (url-portspec url)))
+                                               nil nil t nil (format "%s" (1+ 
(url-portspec url)))))
+                   (password (read-passwd "tuntox password (empty for no 
password): ")))
                (switch-to-buffer-other-window
                 (process-buffer
                  (make-process
@@ -2375,8 +2466,10 @@ Join with DISPLAY-NAME."
                               (unless initialized
                                 (when (ignore-errors (search-backward "Friend 
request accepted"))
                                   (setq initialized t)
-                                  (start-session (process-put network-process 
'tuntox-process proc)))))
-                            (if moving (goto-char (process-mark 
proc)))))))))))))
+                                  (process-put (start-session :host 
"127.0.0.1" :service port)
+                                               'tuntox-process proc))))
+                            (if moving (goto-char (process-mark proc)))))))))))
+               nil))
             (t (error "Unknown protocol \"%s\"" url-type))))))
 
 ;;; overlay tracking