emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[elpa] externals/crdt 569486e6c6 25/44: Lots of changes


From: ELPA Syncer
Subject: [elpa] externals/crdt 569486e6c6 25/44: Lots of changes
Date: Sat, 2 Jul 2022 22:57:34 -0400 (EDT)

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

    Lots of changes
    
    ** DONE Track authorship in-buffer via properties
       ~crdt-visualize-author-mode~ UI
    ** DONE Make interactive changes to crdt-version and crdt-connect
    ** DONE Stop leaking ip address
    ** DONE Investigate why xref-find-definitions causes error
    ** DONE Figure out the code for colouring selection colours from
       ‘default’s :background
    
    - gracefully degrade when TLS handshake fail (I hope it works)
    - remove session name settings
---
 HACKING.org |  32 +++--
 crdt.el     | 407 +++++++++++++++++++++++++++++++-----------------------------
 2 files changed, 228 insertions(+), 211 deletions(-)

diff --git a/HACKING.org b/HACKING.org
index b593ec0d01..3313573ac9 100644
--- a/HACKING.org
+++ b/HACKING.org
@@ -42,31 +42,32 @@ Every message takes the form =(type . body)=
       body takes the form =(buffer-name user-id position-hint . crdt-id-list)=
       - =crdt-id-list= is generated from =CRDT--DUMP-IDS= from the deleted text
 
-  - Peer State
     + cursor ::
       body takes the form
            =(buffer-name user-id point-position-hint point-crdt-id 
mark-position-hint mark-crdt-id)=
       =*-crdt-id= can be either a CRDT ID, or
       - =nil=, which means clear the point/mark
       - =""=, which means =(point-max)=
+  
+  - Contact information
 
     + contact ::
-      body takes the form
-           =(user-id name address port)=
-      when name is =nil=, clear the contact for this =user-id=
+      body takes the form =(user-id slot value)=
+      - =slot= can be one of
+        #+BEGIN_SRC emacs-lisp
+          name host service focus
+        #+END_SRC
 
-    + focus ::
-      body takes the form =(user-id buffer-name)=
+    + leave ::
+      body takes the form =(user-id)=
+      
+      This message is sometime sent from client to server to indicate 
disconnection, 
+      if the underlying proxy doesn't indicate disconnection properly.
 
   - Login
     + hello ::
       This message is sent from client to server, when a client connect to the 
server.
-      body takes the form =(client-name protocol-version &optional response)=
-
-    + leave ::
-      This message is sometime sent from client to server to indicate 
disconnection, 
-      if the underlying proxy doesn't handle it properly.
-      body takes the form =()=
+      body takes the form =(protocol-version &optional response)=
 
     + challenge ::
       body takes the form =(salt)=
@@ -74,7 +75,7 @@ Every message takes the form =(type . body)=
     + login ::
       It's always sent after server receives a hello message.
       Assigns a User ID to the client
-      body takes the form =(user-id session-name)=.
+      body takes the form =(user-id)=.
 
   - Initial Synchronization
     + sync ::
@@ -332,15 +333,12 @@ Q: What if Emacs GCs?
         - =nil=, which means clear the point/mark
 
     + contact :: same as primary protocol.
-
-    + focus :: same as primary protocol.
+    + leave :: same as primary protocol.
 
   - Login
     Note that we don't include challenge/response authentication mecahnism.
 
     + hello :: same as primary protocol.
-    + leave :: same as primary protocol.
-
     + login :: same as primary protocol.
 
   - Initial Synchronization
diff --git a/crdt.el b/crdt.el
index 639d4b8d81..6b5800bdac 100644
--- a/crdt.el
+++ b/crdt.el
@@ -35,14 +35,18 @@
 (require 'url)
 (require 'color)
 (require 'forms)
+(require 'nadvice)
+(require 'gnutls)
 
 (defconst crdt-version "0.3.0")
 (defconst crdt-protocol-version "0.3.0")
 
-(defun crdt-version ()
+(defun crdt-version (&optional message)
   "Show the crdt.el version."
-  (interactive)
-  (message "crdt.el version %s" crdt-version))
+  (interactive (list t))
+  (if message
+      (message "crdt.el version %s" crdt-version)
+    crdt-version))
 
 (defgroup crdt nil
   "Collaborative editing using Conflict-free Replicated Data Types."
@@ -53,10 +57,6 @@
   "Default display name."
   :type 'string)
 
-(defcustom crdt-default-session-name (format "%s_session" (user-login-name))
-  "Default session name."
-  :type 'string)
-
 (defcustom crdt-confirm-disconnect t
   "Ask for confirmation when a CRDT server is to stop the connection from some 
client."
   :type 'boolean)
@@ -81,14 +81,12 @@
   :type 'file)
 
 (defcustom crdt-tls-certificate
-  (concat (file-name-as-directory (if (featurep 'xdg) (xdg-data-home) "~/"))
-          "crdt-tls.pem")
+  (concat user-emacs-directory "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")
+  (concat user-emacs-directory "crdt-tls.pem")
   "Path to TLS private key file used for TLS-secured server."
   :type 'file)
 
@@ -117,25 +115,31 @@ See `crdt-new-session'.'"
   "Override local commands with corresponding remote commands when available."
   :type 'boolean)
 
+(defcustom crdt-region-alpha 0.5
+  "Alpha value for highlighting selections."
+  :type 'float)
+
 ;;; Pseudo cursor/region utils
 
-(defvar crdt-cursor-region-colors
+(defvar crdt-cursor-colors
   (let ((n 10))
     (cl-loop for i below n
           for hue by (/ 1.0 n)
-          collect (cons
-                   (apply #'color-rgb-to-hex
-                          (color-hsl-to-rgb hue 0.5 0.5))
-                   (apply #'color-rgb-to-hex
-                          (color-hsl-to-rgb hue 0.2 0.5))))))
+          collect (color-hsl-to-rgb hue 0.5 0.5)))
+  "List of candidate cursor colors.")
 
 (defun crdt--get-cursor-color (user-id)
   "Get cursor color for USER-ID."
-  (car (nth (mod user-id (length crdt-cursor-region-colors)) 
crdt-cursor-region-colors)))
+  (apply #'color-rgb-to-hex
+         (nth (mod user-id (length crdt-cursor-colors)) crdt-cursor-colors)))
 
 (defun crdt--get-region-color (user-id)
   "Get region color for USER-ID."
-  (cdr (nth (mod user-id (length crdt-cursor-region-colors)) 
crdt-cursor-region-colors)))
+  (apply #'color-rgb-to-hex
+         (cl-mapcar
+          (lambda (a b) (+ (* a crdt-region-alpha) (* b (- 1.0 
crdt-region-alpha))))
+          (nth (mod user-id (length crdt-cursor-colors)) crdt-cursor-colors)
+          (color-name-to-rgb (face-attribute 'default :background)))))
 
 (defun crdt--move-cursor (ov pos)
   "Move pseudo cursor overlay OV to POS."
@@ -324,9 +328,8 @@ Must be used inside CRDT--WITH-INSERTION-INFORMATION."
     (with-current-buffer buffer
       (setq crdt--session session))))
 
-(cl-defstruct (crdt--contact-metadata
-                (:constructor crdt--make-contact-metadata (display-name 
focused-buffer-name host service)))
-  display-name host service focused-buffer-name)
+(cl-defstruct (crdt--contact-metadata (:constructor 
crdt--make-contact-metadata))
+  name host service focus)
 
 (cl-defstruct (crdt-remote-fcap
                 (:constructor crdt--make-remote-fcap
@@ -338,13 +341,15 @@ Must be used inside CRDT--WITH-INSERTION-INFORMATION."
                               (name nonce in-states out-states proxy)))
   name nonce in-states out-states proxy)
 
-(cl-defstruct (crdt--session (:constructor crdt--make-session))
+(cl-defstruct (crdt--session (:constructor crdt--make-session-1))
   local-id                              ; Local user-id
   local-clock                           ; Local logical clock
-  (contact-table (make-hash-table)) ; A hash table that maps USER-ID to 
CRDT--CONTACT-METADATAs
-  local-name
+  (contact-table (make-hash-table))
+  ;; A hash table that maps USER-ID to CRDT--CONTACT-METADATAs
+  ;; Special case: key nil may be mapped to a metadata for a client
+  ;; itself before it gets its user-id. It should be remapped to
+  ;; the right key as soon as client knows its user-id
   name
-  focused-buffer-name
   user-menu-buffer
   buffer-menu-buffer
   network-process
@@ -356,6 +361,17 @@ Must be used inside CRDT--WITH-INSERTION-INFORMATION."
   (local-fcap-table (make-hash-table))
   (remote-fcap-table (make-hash-table)))
 
+(cl-defun crdt--make-session (&rest args &key local-name host service 
&allow-other-keys)
+  (let ((args-1 (cl-copy-list args)))
+    (cl-remf args-1 :local-name)
+    (cl-remf args-1 :host)
+    (cl-remf args-1 :service)
+    (let ((session (apply #'crdt--make-session-1 args-1)))
+      (puthash (crdt--session-local-id session)
+               (crdt--make-contact-metadata :name local-name :host host 
:service service)
+               (crdt--session-contact-table session))
+      session)))
+
 (defvar crdt--inhibit-update nil "When set, don't call CRDT--LOCAL-* on change.
 This is useful for functions that apply remote change to local buffer,
 to avoid recusive calling of CRDT synchronization functions.")
@@ -422,6 +438,11 @@ adding/removing actively tracked overlays.")
 
 (defvar crdt--process nil
   "Temporarily bound to the current network process when processing messages 
inside CRDT--NETWORK-FILTER.")
+
+(defvar crdt--remote-call-spawn-user-id nil
+  "The User ID where current remote call (if any) is orignally called.")
+(defvar crdt--return-message-table (make-hash-table))
+
 (defsubst crdt--client-id ()
   (process-get crdt--process 'client-id))
 
@@ -511,7 +532,7 @@ Also set CRDT--PSEUDO-CURSOR-TABLE to NIL."
      (let ((new-ov (make-overlay beg end nil t nil)))
        (overlay-put new-ov 'category 'crdt-visualize-author)
        (overlay-put new-ov 'crdt-author user-id)
-       (overlay-put new-ov 'face `(:underline ,(crdt--get-cursor-color 
user-id)))))))
+       (overlay-put new-ov 'face `(:background ,(crdt--get-region-color 
user-id)))))))
 
 (defun crdt--visualize-author ()
   (save-restriction
@@ -532,17 +553,25 @@ Also set CRDT--PSEUDO-CURSOR-TABLE to NIL."
       (widen)
       (remove-overlays (point-min) (point-max) 'category 
'crdt-visualize-author))))
 
-;;; Error recovery
-
-(define-error 'crdt-sync-error "CRDT synchronization error")
+;;; Session state utils
 
 (defsubst crdt--server-p (&optional session)
   "Tell if SESSION is running as a server.
 If SESSION is nil, use current CRDT--SESSION."
-  (process-contact
-   (crdt--session-network-process
-    (or session crdt--session))
-   :server))
+  (unless session (setq session crdt--session))
+  (process-contact (crdt--session-network-process session) :server))
+
+(defsubst crdt--session-local-name (session)
+  (crdt--contact-metadata-name
+   (gethash (crdt--session-local-id session) (crdt--session-contact-table 
session))))
+
+(defmacro crdt--session-focused-buffer-name (session)
+  `(crdt--contact-metadata-focus
+    (gethash (crdt--session-local-id ,session) (crdt--session-contact-table 
,session))))
+
+;;; Error recovery
+
+(define-error 'crdt-sync-error "CRDT synchronization error")
 
 (defmacro crdt--with-recover (&rest body)
   "When any error in BODY occur, signal a CRDT-SYNC-ERROR instead.
@@ -619,7 +648,7 @@ until synchronization is completed, otherwise run body 
asynchronously."
      (if (and crdt-buffer (buffer-live-p crdt-buffer))
          (with-current-buffer crdt-buffer
            ,@body)
-       (unless (process-contact (crdt--session-network-process crdt--session) 
:server)
+       (unless (crdt--server-p)
          (setq crdt-buffer (generate-new-buffer (format "%s<%s>" ,name 
(crdt--session-name crdt--session))))
          (puthash ,name crdt-buffer (crdt--session-buffer-table crdt--session))
          (let ((session crdt--session))
@@ -736,11 +765,8 @@ If DISPLAY-BUFFER is provided, display the output there."
                                               (hash-table-keys 
(crdt--session-buffer-table session))
                                               ", ")
                                    (mapconcat (lambda (v) (format "%s" v))
-                                              (let (users)
-                                                (maphash (lambda (_ v)
-                                                           (push 
(crdt--contact-metadata-display-name v) users))
-                                                         
(crdt--session-contact-table session))
-                                                (cons 
(crdt--session-local-name session) users))
+                                              (mapcar 
#'crdt--contact-metadata-name
+                                                      (hash-table-values 
(crdt--session-contact-table session)))
                                               ", ")))
              tabulated-list-entries))
           crdt--session-list)
@@ -821,13 +847,10 @@ Directly return the buffer network name under point if in 
the buffer menu."
     (setq tabulated-list-entries nil)
     (let ((tmp-hashtable (make-hash-table :test 'equal)))
       (maphash (lambda (_ v)
-                 (push (crdt--contact-metadata-display-name v)
-                       (gethash (crdt--contact-metadata-focused-buffer-name v)
+                 (push (crdt--contact-metadata-name v)
+                       (gethash (crdt--contact-metadata-focus v)
                                 tmp-hashtable)))
                (crdt--session-contact-table crdt--session))
-      (push (crdt--session-local-name crdt--session)
-            (gethash (crdt--session-focused-buffer-name crdt--session)
-                     tmp-hashtable))
       (maphash (lambda (k v)
                  (push (list k (vector (if (and v (buffer-live-p v))
                                            (buffer-name v)
@@ -851,7 +874,7 @@ Directly return the buffer network name under point if in 
the buffer menu."
   (let (candidates)
     (maphash
      (lambda (k v)
-       (push (format "%s %s" k (crdt--contact-metadata-display-name v)) 
candidates))
+       (push (format "%s %s" k (crdt--contact-metadata-name v)) candidates))
      (crdt--session-contact-table session))
     (let ((name
            (completing-read "Choose a user: "
@@ -880,7 +903,7 @@ Directly return the user name under point if in the user 
menu."
       (unless
           (cl-block nil
             (let* ((metadata (or (gethash user-id (crdt--session-contact-table 
crdt--session)) (cl-return)))
-                   (buffer-name (or 
(crdt--contact-metadata-focused-buffer-name metadata) (cl-return))))
+                   (buffer-name (or (crdt--contact-metadata-focus metadata) 
(cl-return))))
               (crdt--with-buffer-name-pull (buffer-name)
                (switch-to-buffer-other-window (current-buffer))
                (ignore-errors (goto-char (overlay-start (car (gethash user-id 
crdt--pseudo-cursor-table)))))
@@ -914,8 +937,7 @@ Only server can perform this action."
   (setq tabulated-list-format [("ID" 7 t)
                                ("Display Name" 15 t)
                                ("Follow" 7 t)
-                               ("Focused Buffer" 30 t)
-                               ("Address" 15 t)]))
+                               ("Focused Buffer" 30 t)]))
 
 ;;;###autoload
 (defun crdt-list-users (&optional session)
@@ -938,17 +960,9 @@ Only server can perform this action."
   (with-current-buffer display-buffer
     (crdt-user-menu-mode)
     (setq tabulated-list-entries nil)
-    (push (list (crdt--session-local-id crdt--session)
-                (vector (prin1-to-string (crdt--session-local-id 
crdt--session))
-                        (crdt--session-local-name crdt--session) ""
-                        (or (crdt--session-focused-buffer-name crdt--session) 
"--")
-                        "*myself*"))
-          tabulated-list-entries)
     (maphash (lambda (k v)
-               (push (list k (let ((name (crdt--contact-metadata-display-name 
v))
-                                   (host (crdt--contact-metadata-host v))
-                                   (service (crdt--contact-metadata-service v))
-                                   (focused-buffer-name (or 
(crdt--contact-metadata-focused-buffer-name v) "--")))
+               (push (list k (let ((name (crdt--contact-metadata-name v))
+                                   (focused-buffer-name (or 
(crdt--contact-metadata-focus v) "--")))
                                (let ((colored-name (concat name " ")))
                                  (put-text-property 0 (1- (length 
colored-name))
                                                     'face `(:background 
,(crdt--get-region-color k))
@@ -959,7 +973,7 @@ Only server can perform this action."
                                  (vector (prin1-to-string k) colored-name
                                          (if (eq k 
(crdt--session-follow-user-id crdt--session))
                                              "yes" "")
-                                         focused-buffer-name (format "%s:%s" 
host service)))))
+                                         focused-buffer-name))))
                      tabulated-list-entries))
              (crdt--session-contact-table crdt--session))
     (tabulated-list-init-header)
@@ -989,7 +1003,7 @@ user menu almost always indicate supposed changes in 
buffer menu."
   "Stop following user if any."
   (interactive)
   (message "Stop following %s."
-           (crdt--contact-metadata-display-name
+           (crdt--contact-metadata-name
             (gethash (crdt--session-follow-user-id crdt--session)
                      (crdt--session-contact-table crdt--session))))
   (setf (crdt--session-follow-user-id crdt--session) nil))
@@ -1004,7 +1018,7 @@ It informs other peers that the buffer is killed."
                                      ,(crdt--session-local-id crdt--session) 
nil nil nil nil)))
     (when (eq (crdt--session-focused-buffer-name crdt--session) 
crdt--buffer-network-name)
       (crdt--broadcast-maybe (crdt--format-message
-                              `(focus ,(crdt--session-local-id crdt--session) 
nil)))
+                              `(contact ,(crdt--session-local-id 
crdt--session) focus nil)))
       (setf (crdt--session-focused-buffer-name crdt--session) nil))
     (when (crdt--server-p)
       (crdt-stop-share-buffer))
@@ -1018,7 +1032,7 @@ It informs other peers that the buffer is killed."
 (defsubst crdt-get-fcap (fcap-symbol)
   "Find the active `crdt-remote-fcap' with name FCAP-SYMBOL.
 Signal a `crdt-no-permission' error if no such fcap exists."
-  (or (gethash fcap-symbol (crdt--session-remote-fcap-table crdt--session))
+  (or (and crdt--session (gethash fcap-symbol (crdt--session-remote-fcap-table 
crdt--session)))
       (signal 'crdt-no-permission (list fcap-symbol))))
 
 (cl-defun crdt-make-local-fcap
@@ -1136,8 +1150,10 @@ Copies text properties in CRDT--ENABLED-TEXT-PROPERTIES."
   "To be called after a local insert happened in current buffer from BEG to 
END.
 Returns a list of (insert type) messages to be sent."
   (let* ((user-id (crdt--session-local-id crdt--session)))
+    (unless crdt--site-id
+      (error "No write permission"))
+    (put-text-property beg end 'crdt-author user-id)
     (when crdt-visualize-author-mode
-      (put-text-property beg end 'crdt-author user-id)
       (crdt--visualize-author-1 beg end user-id))
     (let (resulting-fcaps)
       (crdt--with-insertion-information (beg end)
@@ -1163,7 +1179,7 @@ Returns a list of (insert type) messages to be sent."
             (let* ((ending-id (if not-end (crdt--get-starting-id end) ""))
                    (new-id (crdt--generate-id starting-id left-offset
                                               ending-id (if not-end 
(crdt--id-offset ending-id) 0)
-                                              (crdt--session-local-id 
crdt--session))))
+                                              crdt--site-id)))
               (put-text-property beg block-end 'crdt-id (cons new-id t))
               (push `(insert ,crdt--buffer-network-name ,user-id
                              ,new-id ,beg
@@ -1450,10 +1466,12 @@ Always return a message otherwise."
 Check if focused buffer and cursor/mark position are changed.
 Send message to other peers about any changes."
   (crdt--with-should-not-error crdt--post-command
+    ;; CRDT--BEFORE-CHANGE may have sacrificed itself to interrupt a write 
attempt
+    ;; add it back to BEFORE-CHANGE-FUNCTIONS
     (add-to-list 'before-change-functions 'crdt--before-change)
     (unless (eq crdt--buffer-network-name (crdt--session-focused-buffer-name 
crdt--session))
       (crdt--broadcast-maybe
-       (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) 
,crdt--buffer-network-name)))
+       (crdt--format-message `(contact ,(crdt--session-local-id crdt--session) 
focus ,crdt--buffer-network-name)))
       (setf (crdt--session-focused-buffer-name crdt--session) 
crdt--buffer-network-name)
       (crdt--refresh-users-maybe))
     (let ((cursor-message (crdt--local-cursor)))
@@ -1558,11 +1576,11 @@ and the behavior is undefined if OBJECT itself contains 
this symbol."
 
 (cl-defun crdt--broadcast-maybe (message-string &optional (without t))
   "Broadcast or send MESSAGE-STRING.
-If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a server process,
-broadcast MESSAGE-STRING to clients except the one of which CLIENT-ID
-property is EQ to WITHOUT.
-If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a client process,
-send MESSAGE-STRING to server when WITHOUT is non-nil."
+If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a server
+process, broadcast MESSAGE-STRING to clients except the one of
+which CLIENT-ID property is EQ to WITHOUT.
+If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a client
+process, send MESSAGE-STRING to server when WITHOUT is non-nil."
   (if (process-contact (crdt--session-network-process crdt--session) :server)
       (dolist (client (crdt--session-network-clients crdt--session))
         (when (and (eq (process-status client) 'open)
@@ -1695,34 +1713,18 @@ CRDT--PROCESS should be bound to The network process 
for the client connection."
         (process-put crdt--process 'client-id (crdt--session-next-user-id 
crdt--session))
         (setq client-id (crdt--session-next-user-id crdt--session))
         (process-send-string crdt--process (crdt--format-message
-                                      `(login ,client-id
-                                              ,(crdt--session-name 
crdt--session))))
+                                      `(login ,client-id)))
         (cl-incf (crdt--session-next-user-id crdt--session)))
       (process-send-string crdt--process (crdt--format-message
                                           `(add ,@(hash-table-keys 
(crdt--session-buffer-table crdt--session)))))
       ;; synchronize contact
       (maphash (lambda (k v)
-                 (process-send-string crdt--process
-                                      (crdt--format-message
-                                       `(contact ,k 
,(crdt--contact-metadata-display-name v)
-                                                 ,(crdt--contact-metadata-host 
v)
-                                                 
,(crdt--contact-metadata-service v))))
-                 (process-send-string crdt--process
-                                      (crdt--format-message
-                                       `(focus ,k 
,(crdt--contact-metadata-focused-buffer-name v)))))
+                 (dolist (slot '(name focus))
+                   (process-send-string
+                    crdt--process
+                    (crdt--format-message
+                     `(contact ,k ,slot ,(cl-struct-slot-value 
'crdt--contact-metadata slot v))))))
                (crdt--session-contact-table crdt--session))
-      (process-send-string crdt--process
-                           (crdt--format-message
-                            `(contact ,(crdt--session-local-id crdt--session)
-                                      ,(crdt--session-local-name 
crdt--session))))
-      (process-send-string crdt--process
-                           (crdt--format-message
-                            `(focus ,(crdt--session-local-id crdt--session)
-                                    ,(crdt--session-focused-buffer-name 
crdt--session))))
-      (let ((contact-message `(contact ,client-id ,(process-get crdt--process 
'client-name)
-                                       ,(process-contact crdt--process :host)
-                                       ,(process-contact crdt--process 
:service))))
-        (crdt-process-message-1 contact-message))
       ;; send fcaps
       (dolist (fcap (crdt--compute-user-fcaps
                         (crdt--session-permissions crdt--session)
@@ -1831,34 +1833,36 @@ CRDT--PROCESS should be bound to The network process 
for the client connection."
     (when notify-names
       (warn "Server stopped sharing %s."
             (mapconcat #'identity buffer-names ", "))))
-  (dolist (buffer-name buffer-names)
-    (let ((buffer (gethash buffer-name (crdt--session-buffer-table 
crdt--session))))
-      (remhash buffer-name (crdt--session-buffer-table crdt--session))
-      (when buffer
-        (when (buffer-live-p buffer)
-          (with-current-buffer buffer
-            (crdt-mode 0)
-            (setq-local crdt--session nil))))))
-  ;; update focused buffer
-  (maphash (lambda (_k v)
-             (when (member (crdt--contact-metadata-focused-buffer-name v) 
buffer-names)
-               (setf (crdt--contact-metadata-focused-buffer-name v) nil)))
-           (crdt--session-contact-table crdt--session))
-  (crdt--broadcast-maybe crdt--message-string (when crdt--process 
(crdt--client-id)))
-  (crdt--refresh-users-maybe))
-
-(define-crdt-message-handler login (id session-name)
-  (puthash 0 (crdt--make-contact-metadata nil nil
-                                          (process-contact crdt--process :host)
-                                          (process-contact crdt--process 
:service))
-           (crdt--session-contact-table crdt--session))
-  (setf (crdt--session-name crdt--session) (concat session-name "@" 
(crdt--session-name crdt--session)))
+  (let ((session crdt--session))
+    (dolist (buffer-name buffer-names)
+            (let ((buffer (gethash buffer-name (crdt--session-buffer-table 
crdt--session))))
+              (remhash buffer-name (crdt--session-buffer-table crdt--session))
+              (when buffer
+                (when (buffer-live-p buffer)
+                  (with-current-buffer buffer
+                    (crdt-mode 0)
+                    (setq-local crdt--session nil))))))
+    (let ((crdt--session session)) ; hack to avoid crdt--session (somehow) get 
set to nil
+      ;; update focused buffer
+      (maphash (lambda (_k v)
+                 (when (member (crdt--contact-metadata-focus v) buffer-names)
+                   (setf (crdt--contact-metadata-focus v) nil)))
+               (crdt--session-contact-table crdt--session))
+      (crdt--broadcast-maybe crdt--message-string (when crdt--process 
(crdt--client-id)))
+      (crdt--refresh-users-maybe))))
+
+(define-crdt-message-handler login (id)
   (setf (crdt--session-local-id crdt--session) id)
+  (let ((metadata (gethash nil (crdt--session-contact-table crdt--session))))
+    (when metadata
+      (remhash nil (crdt--session-contact-table crdt--session))
+      (process-send-string
+       crdt--process
+       (crdt--format-message
+        `(contact ,id name ,(crdt--contact-metadata-name metadata))))
+      (puthash id metadata (crdt--session-contact-table crdt--session))))
   (crdt--refresh-sessions-maybe))
 
-(define-crdt-message-handler leave ()
-  (delete-process crdt--process))
-
 (define-crdt-message-handler challenge (hash)
   (unless (crdt--server-p)             ; server shouldn't receive this
     (message nil)
@@ -1867,38 +1871,37 @@ CRDT--PROCESS should be bound to The network process 
for the client connection."
                              (process-contact (crdt--session-network-process 
crdt--session) :host)
                              (process-contact (crdt--session-network-process 
crdt--session) :service)))))
       (crdt--broadcast-maybe (crdt--format-message
-                              `(hello ,(crdt--session-local-name 
crdt--session) ,crdt-protocol-version
+                              `(hello ,crdt-protocol-version
                                       ,(gnutls-hash-mac 'SHA1 password 
hash)))))))
 
-(define-crdt-message-handler contact (user-id display-name &optional host 
service)
-  (if display-name
-      (if host
-          (puthash user-id (crdt--make-contact-metadata
-                            display-name nil host service)
-                   (crdt--session-contact-table crdt--session))
-        (let ((existing-item (gethash user-id (crdt--session-contact-table 
crdt--session))))
-          (setf (crdt--contact-metadata-display-name existing-item) 
display-name)))
-    (progn
-      (when (eq user-id (crdt--session-follow-user-id crdt--session))
-        (crdt-stop-follow))
-      (remhash user-id (crdt--session-contact-table crdt--session))))
-  (crdt--refresh-users-maybe)
-  (crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
-
-(define-crdt-message-handler focus (user-id buffer-name)
-  (let ((existing-item (gethash user-id (crdt--session-contact-table 
crdt--session))))
-    (setf (crdt--contact-metadata-focused-buffer-name existing-item) 
buffer-name))
-  ;; (when (and (= user-id 0) (not crdt--focused-buffer-name))
-  ;;   (setq crdt--focused-buffer-name buffer-name)
-  ;;   (switch-to-buffer (gethash buffer-name (crdt--session-buffer-table 
crdt--session))))
+(define-crdt-message-handler contact (user-id slot value)
+  (when (and (crdt--server-p) (not (= user-id (crdt--client-id))))
+    (signal 'crdt-no-permission "User ID mismatch in CONTACT message"))
+  (cl-symbol-macrolet ((metadata (gethash user-id (crdt--session-contact-table 
crdt--session))))
+    (unless metadata (setf metadata (crdt--make-contact-metadata)))
+    (setf (cl-struct-slot-value 'crdt--contact-metadata slot metadata) value))
   (when (eq user-id (crdt--session-follow-user-id crdt--session))
-    (crdt--with-buffer-name-pull (buffer-name)
+    (crdt--with-buffer-name-pull (value)
       (switch-to-buffer (current-buffer))
       (let ((ov-pair (gethash user-id crdt--pseudo-cursor-table)))
         (when ov-pair (goto-char (overlay-start (car ov-pair)))))))
   (crdt--refresh-users-maybe)
   (crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
 
+(define-crdt-message-handler leave (user-id)
+  (if (and (crdt--server-p) (eq (process-status crdt--process) 'open))
+    ;; we must check that process status is open to avoid infinite
+    ;; recursion when the handler is called inside client process sentinel
+      (progn
+        (unless (= user-id (crdt--client-id))
+          (signal 'crdt-no-permission "User ID mismatch in LEAVE message"))
+        (delete-process crdt--process))
+    (when (eq user-id (crdt--session-follow-user-id crdt--session))
+      (crdt-stop-follow))
+    (remhash user-id (crdt--session-contact-table crdt--session))
+    (crdt--refresh-users-maybe)
+    (crdt--broadcast-maybe crdt--message-string (crdt--client-id))))
+
 (defun crdt--network-filter (process string)
   "Network filter function for CRDT network processes.
 Handle received STRING from PROCESS."
@@ -1929,7 +1932,7 @@ Handle received STRING from PROCESS."
                     (crdt-process-message message string))
                 (cl-block nil
                   (when (eq (car message) 'hello)
-                    (cl-destructuring-bind (name protocol-version &optional 
response) (cdr message)
+                    (cl-destructuring-bind (protocol-version &optional 
response) (cdr message)
                       (when (version< protocol-version crdt-protocol-version)
                         (process-send-string process
                                              (crdt--format-message `(error nil 
version ,crdt-protocol-version)))
@@ -1937,7 +1940,6 @@ Handle received STRING from PROCESS."
                       (when (or (not (process-get process 'password)) ; server 
password is empty
                                 (and response (string-equal response 
(process-get process 'challenge))))
                         (process-put process 'authenticated t)
-                        (process-put process 'client-name name)
                         (crdt--greet-client)
                         (cl-return))))
                   (let ((challenge (crdt--generate-challenge)))
@@ -1960,7 +1962,7 @@ Handle received STRING from PROCESS."
             (delq client (crdt--session-network-clients crdt--session)))
       ;; generate a clear cursor message and a clear contact message
       (let* ((client-id (process-get client 'client-id))
-             (clear-contact-message `(contact ,client-id nil)))
+             (clear-contact-message `(leave ,client-id)))
         (when client-id ; we only do stuff if actually a CRDT client 
disconnect, not some spider/scanner etc
           (let ((crdt--process client))
             (crdt-process-message-1 clear-contact-message))
@@ -1968,16 +1970,22 @@ Handle received STRING from PROCESS."
            (lambda (k _)
              (let ((crdt--process client))
                (crdt-process-message-1 `(cursor ,k ,client-id 1 nil 1 nil))))
-           (crdt--session-buffer-table crdt--session))
-          (crdt--refresh-users-maybe)))
+           (crdt--session-buffer-table crdt--session))))
       (when (process-buffer client) (kill-buffer (process-buffer client))))))
 
 (defun crdt--client-process-sentinel (process _message)
   (unless (eq (process-status process) 'open)
-    (when (process-get process 'tuntox-process)
-      (process-send-string process (crdt--format-message '(leave))))
-    (ding)
-    (crdt--stop-session (process-get process 'crdt-session))))
+    (let ((session (process-get process 'crdt-session)))
+      (if session
+          (progn
+            (when (process-get process 'tuntox-process)
+              (process-send-string
+               process
+               (crdt--format-message `(leave ,(crdt--session-local-id 
session)))))
+            (ding)
+            (crdt--stop-session session))
+        ;; This should only happens when we are in the middle of TLS handshake
+        (signal 'file-error "Failed to establish TLS connection.")))))
 
 ;;; UI commands
 
@@ -2150,11 +2158,8 @@ Create a new one if such a CRDT session doesn't exist."
      (when (and crdt-mode crdt--session)
        (error "Current buffer is already shared in a CRDT session"))
      (list (let* ((session-names (mapcar #'crdt--session-name 
crdt--session-list))
-                  (default-name (crdt--generate-new-name 
crdt-default-session-name session-names "%s_%s"))
-                  (session-name (if session-names
-                                    (completing-read "Choose a session (create 
if not exist): "
-                                                     session-names)
-                                  default-name)))
+                  (session-name (and session-names
+                                   (completing-read "Choose a session (create 
if not exist): " session-names))))
              session-name))))
   (let ((session (crdt--get-session session-name)))
     (crdt--share-buffer
@@ -2162,11 +2167,10 @@ Create a new one if such a CRDT session doesn't exist."
      (or session
          (apply #'crdt-new-session
                 (crdt-read-settings
-                 (format "*Settings for %s*" session-name)
+                 (format "*Settings for new CRDT session*")
                  `(("Port: " "6530" ,(crdt--settings-make-ensure-type 
'numberp))
                    ("Secure Port: " ,(if crdt-use-stunnel "6540" "--")
                                     ,(when crdt-use-stunnel 
(crdt--settings-make-ensure-type 'numberp)))
-                   ("Session Name: " ,session-name 
,(crdt--settings-make-ensure-nonempty session-name))
                    ("Password: " "")
                    ("Display Name: " ,crdt-default-name)
                    ("Command Functions: "
@@ -2179,11 +2183,10 @@ Create a new one if such a CRDT session doesn't exist."
   (interactive (let ((session (crdt--read-session-maybe 'server)))
                  (list session (crdt--read-buffer-maybe session))))
   (if session
-      (let ((crdt--session session))
-        (if (crdt--server-p)
-            (let ((remove-message `(remove ,network-name)))
-              (crdt-process-message-1 remove-message))
-          (message "Only server can stop sharing a buffer.")))
+      (if (crdt--server-p)
+          (let ((remove-message `(remove ,network-name)))
+            (crdt-process-message-1 remove-message))
+        (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)
@@ -2226,17 +2229,19 @@ Return the stunnel proxy process."
   (let ((stunnel-process
          (make-process :name "Stunnel Proxy"
                        :buffer (generate-new-buffer "*Stunnel Proxy*")
-                       :command '("stunnel" "/dev/stdin"))))
+                       :command `(,crdt-stunnel-executable "/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))
+                                 (expand-file-name crdt-tls-certificate)
+                                 (expand-file-name crdt-tls-private-key)
+                                 secure-port port))
     (process-send-eof stunnel-process)
     stunnel-process))
 
 (defun crdt-new-session
-    (port secure-port session-name password display-name permissions)
-  "Start a new CRDT session on PORT with SESSION-NAME.
+    (port secure-port password display-name permissions)
+  "Start a new CRDT session on PORT.
 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.
@@ -2263,7 +2268,8 @@ Each element should be one of
                               :local-clock 0
                               :next-user-id 1
                               :local-name display-name
-                              :name session-name
+                              :host "localhost" :service port
+                              :name (format "localhost:%s" port)
                               :network-process network-process
                               :permissions permissions))
          (tuntox-p (or (eq crdt-use-tuntox t)
@@ -2393,6 +2399,19 @@ Join with DISPLAY-NAME."
                          ("tuntox" (setf (url-portspec parsed-url) 6530))))
                      parsed-url)))
       ("Display Name: " ,crdt-default-name 
,(crdt--settings-make-ensure-nonempty crdt-default-name)))))
+  (unless (url-p url)
+    (when (eq (length url) 0)
+      (error "Please input a valid URL"))
+    (let ((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 "eins://" url))))
+      (setq url parsed-url)))
+  (when (not (url-portspec url))
+    (pcase (url-type url)
+      ("eins" (setf (url-portspec url) 6540))
+      ("ein" (setf (url-portspec url) 6530))
+      ("tuntox" (setf (url-portspec url) 6530))))
   (let ((url-type (url-type url)))
     (cl-flet ((start-session (&rest process-args)
                 (let* ((network-process (apply #'make-network-process
@@ -2401,18 +2420,16 @@ Join with DISPLAY-NAME."
                                                :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
+                        (crdt--make-session :name (url-recreate-url url)
+                                            :local-clock 0 :local-name 
display-name
                                             :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)))
+                    `(hello ,crdt-protocol-version)))
                   (let ((crdt--session new-session))
                     (crdt-list-buffers))
                   network-process)))
@@ -2689,16 +2706,14 @@ Join with DISPLAY-NAME."
                 (push (crdt--readable-decode (cadr entry)) vals))))
     (cons vars vals)))
 
-(defvar crdt--remote-call-spawn-user-id nil
-  "The User ID where current remote call (if any) is orignally called.")
-
 (define-crdt-message-handler fcap
     (fcap-symbol nonce in-states out-states &rest interactive-form)
   (puthash fcap-symbol
            (crdt--make-remote-fcap fcap-symbol nonce in-states out-states 
interactive-form)
            (crdt--session-remote-fcap-table crdt--session))
   (when crdt-override-command
-    (advice-add fcap-symbol :around 'crdt--remote-fcap-advice))
+    (advice-add fcap-symbol :around (crdt--make-remote-command-advice 
fcap-symbol)
+                '((name . crdt-remote-fcap))))
   (cl-case fcap-symbol
     ((crdt-get-write-access)
      (dolist (buffer (hash-table-values (crdt--session-buffer-table 
crdt--session)))
@@ -2731,8 +2746,6 @@ Join with DISPLAY-NAME."
     (crdt--log-send-network-traffic msg)
     (process-send-string crdt--process msg)))
 
-(defvar crdt--return-message-table (make-hash-table))
-
 (define-crdt-message-handler return (user-id logical-clock state-list 
success-p &rest return-values)
   (when (eq user-id (crdt--session-local-id crdt--session))
     (puthash logical-clock (cl-list* state-list success-p 
(crdt--readable-decode return-values))
@@ -2769,11 +2782,8 @@ originally started."
   "Remote call REMOTE-FCAP interactively.
 SPAWN-USER-ID is the site where the series of remote calls originally started."
   (crdt-remote-apply remote-fcap
-                    (call-interactively
-                     `(lambda (&rest args)
-                        ,(crdt-remote-fcap-interactive-form remote-fcap)
-                        args))
-                    spawn-user-id))
+                     (advice-eval-interactive-spec 
(crdt-remote-fcap-interactive-form remote-fcap))
+                     spawn-user-id))
 
 (defun crdt-M-x ()
   (interactive)
@@ -2788,17 +2798,26 @@ SPAWN-USER-ID is the site where the series of remote 
calls originally started."
                             t))))
     (crdt-remote-call-interactively (crdt-get-fcap command-symbol) 
(crdt--session-local-id crdt--session))))
 
-(defun crdt--remote-command-advice (orig-func &rest args)
-  "Call remote command named ORIG-FUNC conditionally.
-Call remote command named ORIG-FUNC with ARGS,
-when such remote command is available and
-CRDT-OVERRIDE-COMMAND is non-nil."
-  (let (remote-fcap)
-    (if (and crdt-override-command crdt--session
-             (setq remote-fcap
-                   (gethash orig-func (crdt--session-remote-fcap-table 
crdt--session))))
-        (crdt-remote-apply remote-fcap args)
-      (apply orig-func args))))
+(defun crdt--make-remote-command-advice (func)
+  (eval
+   `(cl-macrolet
+        ((if-remote (then else)
+           `(let (remote-fcap)
+             (if (and crdt-override-command
+                      (setq remote-fcap (ignore-error crdt-no-permission 
(crdt-get-fcap ',',func))))
+                 ,then ,else))))
+      (lambda (orig-func &rest args)
+        "Call remote command named ORIG-FUNC conditionally.
+Call remote command named ORIG-FUNC with ARGS, when such remote
+command is available and CRDT-OVERRIDE-COMMAND is non-nil."
+        (interactive
+         (lambda (orig-interactive)
+           (if-remote
+            (advice-eval-interactive-spec (crdt-remote-fcap-interactive-form 
remote-fcap))
+            (advice-eval-interactive-spec orig-interactive))))
+        (if-remote
+         (crdt-remote-apply remote-fcap args)
+         (apply orig-func args))))))
 
 ;;; Buffer local variables
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]