3428 lines
154 KiB
EmacsLisp
3428 lines
154 KiB
EmacsLisp
;;; crdt.el --- Collaborative editing using Conflict-free Replicated Data Types -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2021 Free Software Foundation, Inc.
|
|
|
|
;; Author: Qiantan Hong <qhong@alum.mit.edu>
|
|
;; Maintainer: Qiantan Hong <qhong@alum.mit.edu>
|
|
;; URL: https://code.librehq.com/qhong/crdt.el
|
|
;; Keywords: collaboration crdt
|
|
;; Version: 0.3.5
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs 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.
|
|
|
|
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
;; This package provides a collaborative editing environment for Emacs.
|
|
|
|
;;; Code:
|
|
|
|
;;; Customs
|
|
|
|
(require 'xdg nil t)
|
|
(require 'cl-lib)
|
|
(require 'url)
|
|
(require 'color)
|
|
(require 'forms)
|
|
(require 'nadvice)
|
|
(require 'gnutls)
|
|
|
|
(defconst crdt-version "0.3.5")
|
|
(defconst crdt-protocol-version "0.3.0")
|
|
|
|
(defun crdt-version (&optional message)
|
|
"Show the crdt.el 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."
|
|
:prefix "crdt-"
|
|
:group 'applications)
|
|
|
|
(defcustom crdt-default-name (user-full-name)
|
|
"Default display 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)
|
|
|
|
(defvar crdt--log-network-traffic nil
|
|
"Debug switch to log network traffic to *Messages*.")
|
|
|
|
(defvar crdt--inhibit-recover nil
|
|
"Debug switch to disable error recovery mechanism.
|
|
This includes `crdt--with-recover' and `crdt--with-should-not-error'.")
|
|
|
|
(defcustom crdt-tuntox-executable "tuntox"
|
|
"Path to the tuntox binary."
|
|
:type 'file)
|
|
|
|
(defcustom crdt-tuntox-key-path (if (featurep 'xdg) (xdg-data-home) "~/")
|
|
"Path to save tuntox's private key."
|
|
:type 'directory)
|
|
|
|
(defcustom crdt-use-tuntox nil
|
|
"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
|
|
(locate-user-emacs-file "crdt-tls.pem")
|
|
"Path to TLS certificate file used for TLS-secured server."
|
|
:type 'file)
|
|
|
|
(defcustom crdt-tls-private-key
|
|
(locate-user-emacs-file "crdt-tls.pem")
|
|
"Path to TLS private key file used for TLS-secured server."
|
|
:type 'file)
|
|
|
|
(defcustom crdt-use-stunnel nil
|
|
"Start stunnel proxy for CRDT servers."
|
|
:type '(choice boolean (const confirm)))
|
|
|
|
(defcustom crdt-default-tls nil
|
|
"Connecting with TLS (eins) protocol by default."
|
|
:type 'boolean)
|
|
|
|
(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"
|
|
"\\[exit-recursive-edit]:OK, \\[abort-recursive-edit]:Cancel\n")
|
|
"Help string for `crdt-read-settings'."
|
|
:type 'string)
|
|
|
|
(defcustom crdt-default-session-permissions
|
|
'(crdt-write-access-fcaps
|
|
crdt-create-buffer-fcaps
|
|
crdt-comint-fcaps
|
|
crdt-xscheme-fcaps
|
|
crdt-xref-fcaps)
|
|
"A list that describes default policies for public session-scoped functions.
|
|
See `crdt-new-session'.'"
|
|
:type '(list (or function symbol)))
|
|
|
|
(defcustom crdt-override-command t
|
|
"Override local commands with corresponding remote commands when available."
|
|
:type 'boolean)
|
|
|
|
(defcustom crdt-region-alpha 0.2
|
|
"Alpha value for highlighting selections."
|
|
:type 'float)
|
|
|
|
(defcustom crdt-tuntox-password-in-url nil
|
|
"Whether or not to include the session password in the tuntox connection URL.
|
|
Useful if you plan to share your session URL over a trusted secure channel. Your
|
|
password will be in plaintext in the URL, so take care when sharing URLs with
|
|
this option enabled."
|
|
:type 'boolean)
|
|
|
|
;;; Pseudo cursor/region utils
|
|
|
|
(defvar crdt-cursor-colors
|
|
(let ((n 10))
|
|
(cl-loop for i below n
|
|
for hue by (/ 1.0 n)
|
|
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."
|
|
(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."
|
|
(let ((background-rgb (color-name-to-rgb (face-attribute 'default :background))))
|
|
(if background-rgb
|
|
(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)
|
|
background-rgb))
|
|
(crdt--get-cursor-color user-id))))
|
|
|
|
(defun crdt--move-cursor (ov pos)
|
|
"Move pseudo cursor overlay OV to POS."
|
|
;; Hax!
|
|
(let* ((eof (eq pos (point-max)))
|
|
(end (if eof pos (1+ pos)))
|
|
(display-string
|
|
(when eof
|
|
(unless (or (eq (point) (point-max))
|
|
(cl-some (lambda (ov)
|
|
(and (eq (overlay-get ov 'category) 'crdt-pseudo-cursor)
|
|
(overlay-get ov 'before-string)))
|
|
(overlays-in (point-max) (point-max))))
|
|
(propertize " " 'face (overlay-get ov 'face))))))
|
|
(move-overlay ov pos end)
|
|
(overlay-put ov 'before-string display-string)))
|
|
|
|
(defun crdt--move-region (ov pos mark)
|
|
"Move pseudo marked region overlay OV to mark between POS and MARK."
|
|
(move-overlay ov (min pos mark) (max pos mark)))
|
|
|
|
;;; CRDT ID utils
|
|
;; CRDT IDs are represented by unibyte strings (for efficient comparison)
|
|
;; Every two bytes represent a big endian encoded integer
|
|
;; For base IDs, last two bytes are always representing site ID
|
|
;; Stored strings are BASE-ID:OFFSETs. So the last two bytes represent offset,
|
|
;; and second last two bytes represent site ID
|
|
(defconst crdt--max-value (lsh 1 16))
|
|
;; (defconst crdt--max-value 16)
|
|
;; for debug
|
|
(defconst crdt--low-byte-mask 255)
|
|
|
|
(defsubst crdt--get-two-bytes (string index)
|
|
"Get the big-endian encoded integer from STRING starting from INDEX.
|
|
INDEX is counted by bytes."
|
|
(logior (lsh (elt string index) 8)
|
|
(elt string (1+ index))))
|
|
|
|
(defsubst crdt--get-two-bytes-with-offset (string offset index default)
|
|
"Helper function for CRDT--GENERATE-ID.
|
|
Get the big-endian encoded integer from STRING starting from INDEX,
|
|
but with last two-bytes of STRING (the offset portion) replaced by OFFSET,
|
|
and padded infintely by DEFAULT to the right."
|
|
(cond ((= index (- (string-bytes string) 2))
|
|
offset)
|
|
((< (1+ index) (string-bytes string))
|
|
(logior (lsh (elt string index) 8)
|
|
(elt string (1+ index))))
|
|
(t default)))
|
|
|
|
(defsubst crdt--id-offset (id)
|
|
"Get the literal offset integer from ID.
|
|
Note that it might deviate from real offset for a character
|
|
in the middle of a block."
|
|
(crdt--get-two-bytes id (- (string-bytes id) 2)))
|
|
|
|
(defsubst crdt--set-id-offset (id offset)
|
|
"Set the OFFSET portion of ID destructively."
|
|
(let ((length (string-bytes id)))
|
|
(aset id (- length 2) (lsh offset -8))
|
|
(aset id (- length 1) (logand offset crdt--low-byte-mask))))
|
|
|
|
(defsubst crdt--id-replace-offset (id offset)
|
|
"Create and return a new id string by replacing the OFFSET portion from ID."
|
|
(let ((new-id (substring id)))
|
|
(crdt--set-id-offset new-id offset)
|
|
new-id))
|
|
|
|
(defsubst crdt--id-site (id)
|
|
"Get the site id from ID."
|
|
(crdt--get-two-bytes id (- (string-bytes id) 4)))
|
|
|
|
(defsubst crdt--generate-id (low-id low-offset high-id high-offset site-id)
|
|
"Generate a new ID between LOW-ID and HIGH-ID.
|
|
The generating site is marked as SITE-ID.
|
|
Offset parts of LOW-ID and HIGH-ID are overriden by LOW-OFFSET
|
|
and HIGH-OFFSET. (to save two copying from using CRDT--ID-REPLACE-OFFSET)"
|
|
(let* ((l (crdt--get-two-bytes-with-offset low-id low-offset 0 0))
|
|
(h (crdt--get-two-bytes-with-offset high-id high-offset 0 crdt--max-value))
|
|
(bytes (cl-loop for pos from 2 by 2
|
|
while (< (- h l) 2)
|
|
append (list (lsh l -8)
|
|
(logand l crdt--low-byte-mask))
|
|
do (setq l (crdt--get-two-bytes-with-offset low-id low-offset pos 0))
|
|
do (setq h (crdt--get-two-bytes-with-offset high-id high-offset pos crdt--max-value))))
|
|
(m (+ l 1 (random (- h l 1)))))
|
|
(apply #'unibyte-string
|
|
(append bytes (list (lsh m -8)
|
|
(logand m crdt--low-byte-mask)
|
|
(lsh site-id -8)
|
|
(logand site-id crdt--low-byte-mask)
|
|
0
|
|
0)))))
|
|
|
|
;; CRDT-ID text property actually stores a cons of (ID-STRING . END-OF-BLOCK-P)
|
|
(defsubst crdt--get-crdt-id-pair (pos &optional obj)
|
|
"Get the (CRDT-ID . END-OF-BLOCK-P) pair at POS in OBJ."
|
|
(get-text-property pos 'crdt-id obj))
|
|
|
|
(defsubst crdt--get-starting-id (pos &optional obj)
|
|
"Get the CRDT-ID object at POS in OBJ."
|
|
(car (crdt--get-crdt-id-pair pos obj)))
|
|
|
|
(defsubst crdt--end-of-block-p (pos &optional obj)
|
|
"Get the END-OF-BLOCK-P at POS in OBJ."
|
|
(cdr (crdt--get-crdt-id-pair pos obj)))
|
|
|
|
(defsubst crdt--get-starting-id-maybe (pos &optional obj limit)
|
|
"Get the CRDT-ID at POS in OBJ if POS is no smaller than LIMIT.
|
|
Return NIL otherwise."
|
|
(unless (< pos (or limit (point-min)))
|
|
(car (get-text-property pos 'crdt-id obj))))
|
|
|
|
(defsubst crdt--get-id-offset (starting-id pos &optional obj limit)
|
|
"Get the real offset integer for a character at POS.
|
|
Assume the stored literal ID is STARTING-ID."
|
|
(let* ((start-pos (previous-single-property-change (1+ pos) 'crdt-id obj (or limit (point-min)))))
|
|
(+ (- pos start-pos) (crdt--id-offset starting-id))))
|
|
|
|
;;; CRDT ID and text property utils
|
|
|
|
(defsubst crdt--get-id (pos &optional obj left-limit right-limit)
|
|
"Get the real CRDT ID at POS in OBJ.
|
|
The search for start and end of CRDT ID block is limited by LEFT-LIMIT and RIGHT-LIMIT."
|
|
(let ((right-limit (or right-limit (point-max)))
|
|
(left-limit (or left-limit (point-min))))
|
|
(cond ((>= pos right-limit) "")
|
|
((< pos left-limit) nil)
|
|
(t
|
|
(let* ((starting-id (crdt--get-starting-id pos obj))
|
|
(left-offset (crdt--get-id-offset starting-id pos obj left-limit)))
|
|
(crdt--id-replace-offset starting-id left-offset))))))
|
|
|
|
(defsubst crdt--set-id (pos id &optional end-of-block-p obj limit)
|
|
"Set the crdt ID and END-OF-BLOCK-P at POS in OBJ.
|
|
Any characters after POS but before LIMIT that used to
|
|
have the same (CRDT-ID . END-OF-BLOCK-P) pair are also updated
|
|
with ID and END-OF-BLOCK-P."
|
|
(put-text-property pos (next-single-property-change pos 'crdt-id obj (or limit (point-max))) 'crdt-id (cons id end-of-block-p) obj))
|
|
|
|
(cl-defmacro crdt--with-insertion-information
|
|
((beg end &optional beg-obj end-obj beg-limit end-limit) &body body)
|
|
"Setup some useful variables relevant to an insertion and evaluate BODY.
|
|
The insert happens between BEG in BEG-OBJ and END in END-OBJ,
|
|
if BEG-OBJ or END-OBJ is NIL, it is treated as current buffer.
|
|
The search for start and end of CRDT ID block is limited by BEG-LIMIT and END-LIMIT."
|
|
(declare (indent 1) (debug ([&rest form] body)))
|
|
`(let* ((not-begin (> ,beg ,(or beg-limit '(point-min)))) ; if it's nil, we're at the beginning of buffer
|
|
(left-pos (1- ,beg))
|
|
(starting-id-pair (when not-begin (crdt--get-crdt-id-pair left-pos ,beg-obj)))
|
|
(starting-id (if not-begin (car starting-id-pair) ""))
|
|
(left-offset (if not-begin (crdt--get-id-offset starting-id left-pos ,beg-obj ,beg-limit) 0))
|
|
(not-end (< ,end ,(or end-limit '(point-max))))
|
|
;; (beg ,beg) ; it happens that no function relies on this particular binding
|
|
(end ,end)
|
|
(beg-obj ,beg-obj)
|
|
(end-obj ,end-obj)
|
|
;; (beg-limit ,beg-limit) ; it happens that no function uses it right now.
|
|
(end-limit ,end-limit))
|
|
,@body))
|
|
|
|
(defmacro crdt--split-maybe ()
|
|
"Split the block if current insertion lies in some CRDT ID block.
|
|
Must be used inside CRDT--WITH-INSERTION-INFORMATION."
|
|
'(when (and not-end (eq starting-id (crdt--get-starting-id end end-obj)))
|
|
;; need to split id block
|
|
(crdt--set-id end (crdt--id-replace-offset starting-id (1+ left-offset))
|
|
(crdt--end-of-block-p left-pos beg-obj) end-obj end-limit)
|
|
(rplacd (get-text-property left-pos 'crdt-id beg-obj) nil) ;; clear end-of-block flag
|
|
t))
|
|
|
|
;;; Buffer local variables
|
|
|
|
(defmacro crdt--defvar-permanent-local (name &optional initial-value docstring)
|
|
"Define a permanent local variable with NAME with INITIAL-VALUE and DOCSTRING."
|
|
(declare (indent 2) (doc-string 3) (debug defvar-local))
|
|
`(progn
|
|
(defvar-local ,name ,initial-value ,docstring)
|
|
(put ',name 'permanent-local t)))
|
|
|
|
(crdt--defvar-permanent-local crdt--session)
|
|
|
|
(defsubst crdt--assimilate-session (buffer)
|
|
"Set CRDT--SESSION of BUFFER to be the same as current CRDT--SESSION."
|
|
(let ((session crdt--session))
|
|
(with-current-buffer buffer
|
|
(setq crdt--session session))))
|
|
|
|
(cl-defstruct (crdt--contact-metadata (:constructor crdt--make-contact-metadata))
|
|
name host service focus)
|
|
|
|
(cl-defstruct (crdt-remote-fcap
|
|
(:constructor crdt--make-remote-fcap
|
|
(name nonce in-states out-states interactive-form)))
|
|
name nonce in-states out-states interactive-form)
|
|
|
|
(cl-defstruct (crdt-local-fcap
|
|
(:constructor crdt--make-local-fcap
|
|
(name nonce in-states out-states proxy)))
|
|
name nonce in-states out-states proxy)
|
|
|
|
(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
|
|
;; 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
|
|
urlstr
|
|
roger-p ;; set to t when network filter hear any data
|
|
;; to indicate that TLS handshake (if any) must have completed
|
|
user-menu-buffer
|
|
buffer-menu-buffer
|
|
network-process
|
|
network-clients
|
|
next-user-id
|
|
(buffer-table (make-hash-table :test 'equal)) ; maps buffer network name to buffer
|
|
follow-user-id
|
|
my-location-marker ; used to store my location temporarily when crdt-goto-{next,prev}-user
|
|
permissions
|
|
(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.")
|
|
|
|
(crdt--defvar-permanent-local crdt--changed-string nil
|
|
"Save changed substring in CRDT--BEFORE-CHANGE.")
|
|
(crdt--defvar-permanent-local crdt--changed-start nil
|
|
"Save start character address of changes in CRDT--BEFORE-CHANGE,
|
|
to recover the portion being overwritten in CRDT--AFTER-CHANGE.")
|
|
|
|
(crdt--defvar-permanent-local crdt--last-point nil)
|
|
(crdt--defvar-permanent-local crdt--last-mark nil)
|
|
(crdt--defvar-permanent-local crdt--last-process-mark-id nil)
|
|
|
|
(crdt--defvar-permanent-local crdt--pseudo-cursor-table nil
|
|
"A hash table that maps USER-ID to CONSes.
|
|
Each element is of the form (CURSOR-OVERLAY . REGION-OVERLAY).")
|
|
|
|
(crdt--defvar-permanent-local crdt--site-id-table nil
|
|
"A hash table that maps USER-ID to SITE-ID. Only used by the publisher of the buffer.")
|
|
(crdt--defvar-permanent-local crdt--site-id-list nil
|
|
"A list of all allocated SITE-ID (except 0 which is reserved for publisher), sorted by value.")
|
|
(crdt--defvar-permanent-local crdt--site-id-use-list nil
|
|
"A list of all allocated SITE-ID (except 0 which is reserved for publisher), sorted by recent usage.")
|
|
(crdt--defvar-permanent-local crdt--site-id nil "My SITE-ID at this buffer.")
|
|
|
|
(cl-defstruct (crdt--overlay-metadata
|
|
(:constructor crdt--make-overlay-metadata
|
|
(lamport-timestamp species front-advance rear-advance plist))
|
|
(:copier crdt--copy-overlay-metadata))
|
|
lamport-timestamp species front-advance rear-advance plist)
|
|
|
|
(crdt--defvar-permanent-local crdt--overlay-table nil
|
|
"A hash table that maps CONSes of the form (USER-ID . LOGICAL-CLOCK) to overlays.")
|
|
|
|
(crdt--defvar-permanent-local crdt--buffer-network-name)
|
|
|
|
(crdt--defvar-permanent-local crdt--buffer-sync-callback)
|
|
|
|
(crdt--defvar-permanent-local crdt--buffer-pseudo-process)
|
|
|
|
(defvar crdt--track-overlay-species nil
|
|
"Label any newly created overlay with its value as their ``species''.
|
|
You usually want to dynamically bound this variable,
|
|
so that overlays created during a dynamic extent
|
|
are categorized into the same ``species''.
|
|
You can then enable synchronizing those overlays using
|
|
function CRDT--ENABLE-OVERLAY-SPECIES.")
|
|
(defvar-local crdt--enabled-overlay-species nil
|
|
"A list of ``species'' of overlays that are tracked and synchronized.
|
|
See CRDT--TRACK-OVERLAY-SPECIES.
|
|
You should always use CRDT--ENABLE-OVERLAY-SPECIES
|
|
and CRDT--DISABLE-OVERLAY-SPECIES to modify this variable
|
|
as those functions handle bookkeeping of
|
|
adding/removing actively tracked overlays.")
|
|
|
|
(defvar-local crdt--enabled-text-properties '(crdt-author)
|
|
"A list of text properties that are tracked and synchronized.")
|
|
|
|
;;; Global variables
|
|
|
|
(defvar crdt--session-list nil)
|
|
(defvar crdt--session-menu-buffer nil)
|
|
|
|
(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))
|
|
|
|
;;; crdt-mode
|
|
|
|
(defvar crdt--hooks-alist
|
|
'((after-change-functions . crdt--after-change)
|
|
(before-change-functions . crdt--before-change)
|
|
(post-command-hook . crdt--post-command)
|
|
(deactivate-mark-hook . crdt--post-command)
|
|
(kill-buffer-hook . crdt--kill-buffer-hook)
|
|
(clone-buffer-hook . crdt--clone-buffer-hook)
|
|
(clone-indirect-buffer-hook . crdt--clone-buffer-hook)))
|
|
|
|
(defun crdt--install-hooks ()
|
|
"Install the hooks used by CRDT-MODE."
|
|
(dolist (pair crdt--hooks-alist)
|
|
(add-hook (car pair) (cdr pair) nil t)))
|
|
|
|
(defun crdt--uninstall-hooks ()
|
|
"Uninstall the hooks used by CRDT-MODE."
|
|
(dolist (pair crdt--hooks-alist)
|
|
(remove-hook (car pair) (cdr pair) t)))
|
|
|
|
(defsubst crdt--clear-pseudo-cursor-table ()
|
|
"Remove all overlays in CRDT--PSEUDO-CURSOR-TABLE.
|
|
Also set CRDT--PSEUDO-CURSOR-TABLE to NIL."
|
|
(when crdt--pseudo-cursor-table
|
|
(maphash (lambda (_ pair)
|
|
(delete-overlay (car pair))
|
|
(delete-overlay (cdr pair)))
|
|
crdt--pseudo-cursor-table)
|
|
(setq crdt--pseudo-cursor-table nil)))
|
|
|
|
(defun crdt--after-change-major-mode ()
|
|
"Re-enable CRDT-MODE after major mode change."
|
|
(when (and crdt--session crdt--buffer-network-name
|
|
(eq (current-buffer)
|
|
(gethash crdt--buffer-network-name
|
|
(crdt--session-buffer-table crdt--session))))
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode)) nil)
|
|
(crdt-mode)))
|
|
|
|
(add-hook 'after-change-major-mode-hook #'crdt--after-change-major-mode)
|
|
|
|
(define-minor-mode crdt-mode
|
|
"Mode for source collaborative buffers."
|
|
:lighter " CRDT"
|
|
(if crdt-mode
|
|
(progn
|
|
(unless crdt--pseudo-cursor-table
|
|
(setq crdt--pseudo-cursor-table (make-hash-table)))
|
|
(unless crdt--overlay-table
|
|
(setq crdt--overlay-table (make-hash-table :test 'equal)))
|
|
(setq crdt--site-id-list (list 0 crdt--max-value))
|
|
(crdt--install-hooks))
|
|
(crdt--uninstall-hooks)
|
|
(crdt--clear-pseudo-cursor-table)
|
|
(setq crdt--overlay-table nil crdt--site-id-list nil
|
|
crdt--buffer-network-name nil)))
|
|
|
|
(defun crdt--clone-buffer-hook ()
|
|
(crdt-mode -1))
|
|
|
|
(defvar crdt-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "M-X") #'crdt-M-x)
|
|
map))
|
|
|
|
(or (assq 'crdt-mode minor-mode-map-alist)
|
|
(nconc minor-mode-map-alist
|
|
(list (cons 'crdt-mode crdt-mode-map))))
|
|
|
|
;;; Author visualization
|
|
|
|
(defsubst crdt--visualize-author-1 (beg end user-id)
|
|
(remove-overlays beg end 'category 'crdt-visualize-author)
|
|
(cl-flet ((ov-alike-p (ov)
|
|
(and (eq (overlay-get ov 'category) 'crdt-visualize-author)
|
|
(eq (overlay-get ov 'crdt-author) user-id))))
|
|
(or
|
|
(let ((ov-front (cl-find-if #'ov-alike-p (overlays-at (1- beg)))))
|
|
(when ov-front (move-overlay ov-front (overlay-start ov-front) end) t))
|
|
(let ((ov-rear (cl-find-if #'ov-alike-p (overlays-at end))))
|
|
(when ov-rear (move-overlay ov-rear beg (overlay-end ov-rear)) t))
|
|
(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 `(:background ,(crdt--get-region-color user-id)))))))
|
|
|
|
(defun crdt--visualize-author ()
|
|
(save-restriction
|
|
(widen)
|
|
(let ((pos (point-max)))
|
|
(while (> pos (point-min))
|
|
(let* ((prev-pos (previous-single-property-change pos 'crdt-author nil (point-min)))
|
|
(user-id (get-text-property prev-pos 'crdt-author)))
|
|
(when user-id (crdt--visualize-author-1 prev-pos pos user-id))
|
|
(setq pos prev-pos))))))
|
|
|
|
(define-minor-mode crdt-visualize-author-mode
|
|
"Minor mode to visualize who wrote what."
|
|
:lighter " CRDT-VAuthor"
|
|
(if crdt-visualize-author-mode
|
|
(crdt--visualize-author)
|
|
(save-restriction
|
|
(widen)
|
|
(remove-overlays (point-min) (point-max) 'category 'crdt-visualize-author))))
|
|
|
|
;;; 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."
|
|
(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.
|
|
This will hopefully trigger error recovery mechanism when further unwinding the stack."
|
|
(declare (indent 1) (debug (sexp def-body)))
|
|
`(if crdt--inhibit-recover
|
|
(progn ,@body)
|
|
(condition-case nil
|
|
(progn ,@ body)
|
|
(error (signal 'crdt-sync-error nil)))))
|
|
|
|
(defmacro crdt--with-should-not-error (name &rest body)
|
|
"When any error in BODY occur, print a report and stop CRDT in this buffer.
|
|
NAME is included in the report."
|
|
(declare (indent 1) (debug (sexp def-body)))
|
|
`(if crdt--inhibit-recover
|
|
(progn ,@body)
|
|
(condition-case err
|
|
(progn ,@ body)
|
|
(error
|
|
(warn "CRDT mode exited in buffer %s because of error %s inside %s."
|
|
(current-buffer) err ',name)
|
|
(if (crdt--server-p)
|
|
(crdt-stop-share-buffer)
|
|
(remhash crdt--buffer-network-name (crdt--session-buffer-table crdt--session))
|
|
(crdt--refresh-buffers-maybe)
|
|
(crdt-mode -1))))))
|
|
|
|
(defun crdt--recover (&optional err)
|
|
"Try to recover from a synchronization failure.
|
|
Current buffer is assmuned to be the one with synchronization error.
|
|
If we are the server, ERR is the error we shall report to client."
|
|
(if (crdt--server-p)
|
|
(progn
|
|
(let ((message (crdt--format-message `(error ,crdt--buffer-network-name ,(car err) ,(crdt--readable-encode (cdr err))))))
|
|
(process-send-string crdt--process message)))
|
|
(ding)
|
|
(read-only-mode)
|
|
(message "Synchronization error detected, try recovering...")
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message `(get ,crdt--buffer-network-name)))))
|
|
|
|
;;; Shared buffer utils
|
|
|
|
(defun crdt--call-with-buffer-name (name function)
|
|
"Find CRDT shared buffer associated with NAME and call FUNCTION in it.
|
|
See `crdt--with-buffer-name'."
|
|
(let (crdt-buffer)
|
|
(setq crdt-buffer (gethash name (crdt--session-buffer-table crdt--session)))
|
|
(when (and crdt-buffer (buffer-live-p crdt-buffer))
|
|
(with-current-buffer crdt-buffer
|
|
(save-restriction
|
|
(widen)
|
|
(condition-case err
|
|
(funcall function)
|
|
(crdt-sync-error (crdt--recover err))))))))
|
|
|
|
(defmacro crdt--with-buffer-name (name &rest body)
|
|
"Find CRDT shared buffer associated with NAME and evaluate BODY in it.
|
|
Any narrowing is temporarily disabled during evaluation of BODY.
|
|
Also, try to recover from synchronization error if any error happens in BODY.
|
|
Must be called when CURRENT-BUFFER is a CRDT status buffer.
|
|
If such buffer doesn't exist yet, do nothing."
|
|
(declare (indent 1) (debug (sexp def-body)))
|
|
`(crdt--call-with-buffer-name ,name (lambda () ,@body)))
|
|
|
|
(cl-defmacro crdt--with-buffer-name-pull ((name &key sync) &rest body)
|
|
"Find CRDT shared buffer associated with NAME and evaluate BODY in it.
|
|
Must be called when CURRENT-BUFFER is a CRDT status buffer.
|
|
If such buffer doesn't exist yet, request it from the server,
|
|
and store the body in CRDT--BUFFER-SYNC-CALLBACK to evaluate it
|
|
after synchronization is completed.
|
|
If SYNC is non-nil, block (but allow process filters to run)
|
|
until synchronization is completed, otherwise run body asynchronously."
|
|
(declare (indent 1) (debug (sexp def-body)))
|
|
`(let (crdt-buffer)
|
|
(setq crdt-buffer (gethash ,name (crdt--session-buffer-table crdt--session)))
|
|
(if (and crdt-buffer (buffer-live-p crdt-buffer))
|
|
(with-current-buffer crdt-buffer
|
|
,@body)
|
|
(unless (crdt--server-p)
|
|
(setq crdt-buffer (generate-new-buffer (format "%s<%s>" ,name (crdt--session-urlstr crdt--session))))
|
|
(puthash ,name crdt-buffer (crdt--session-buffer-table crdt--session))
|
|
(let ((session crdt--session))
|
|
(with-current-buffer crdt-buffer
|
|
(setq crdt--buffer-network-name ,name)
|
|
(setq crdt--session session)
|
|
(crdt-mode)
|
|
(crdt--broadcast-maybe (crdt--format-message `(get ,,name)))
|
|
(let ((crdt--inhibit-update t))
|
|
(insert "Synchronizing with server...")
|
|
(read-only-mode))
|
|
,(if sync
|
|
`(let (sync-complete)
|
|
(setq crdt--buffer-sync-callback
|
|
(lambda () (setq sync-complete t)))
|
|
(while (not sync-complete)
|
|
(accept-process-output))
|
|
,@body)
|
|
`(setq crdt--buffer-sync-callback
|
|
(lambda ()
|
|
,@body)))))))))
|
|
|
|
;;; Session menu
|
|
|
|
(defsubst crdt--get-session-names (server)
|
|
"Get session names for CRDT sessions (from `crdt--session-list').
|
|
If SERVER is non-NIL, return the list of names for server sessions.
|
|
Otherwise, return the list of names for client sessions."
|
|
(let (session-names)
|
|
(dolist (session crdt--session-list)
|
|
(when (eq (crdt--server-p session) server)
|
|
(push (crdt--session-urlstr session) session-names)))
|
|
(nreverse session-names)))
|
|
|
|
(defsubst crdt--get-session (name)
|
|
"Get the CRDT session object with NAME."
|
|
(cl-find name crdt--session-list
|
|
:test 'equal :key #'crdt--session-urlstr))
|
|
|
|
(defsubst crdt--completing-read (prompt collection &optional initial-input)
|
|
"Like (completing-read PROMPT COLLECTION nil t INITIAL-INPUT).
|
|
Do better when there are 0 or 1 candidates."
|
|
(if collection
|
|
(if (cdr collection)
|
|
(completing-read prompt collection nil t initial-input)
|
|
(car collection))
|
|
(signal 'quit "No candidates")))
|
|
|
|
(defun crdt--read-session (&optional filter)
|
|
"Prompt for a session name and return the corresponding session.
|
|
FILTER can be nil, 'server or 'client."
|
|
(crdt--get-session
|
|
(crdt--completing-read
|
|
(format "Choose a%s session: "
|
|
(cl-ecase filter
|
|
((server) " server")
|
|
((client) " client")
|
|
((nil) "")))
|
|
(cl-ecase filter
|
|
((server) (crdt--get-session-names t))
|
|
((client) (crdt--get-session-names nil))
|
|
((nil) (mapcar #'crdt--session-urlstr crdt--session-list)))
|
|
(when (and crdt--session
|
|
(cl-ecase filter
|
|
((server) (crdt--server-p))
|
|
((client) (not (crdt--server-p)))
|
|
((nil) t)))
|
|
(crdt--session-urlstr crdt--session)))))
|
|
|
|
(defun crdt--read-session-maybe (&optional filter)
|
|
"Prompt for a session name and return the corresponding session.
|
|
Directly return the session name under point if in the session menu.
|
|
FILTER can be nil, 'server or 'client."
|
|
(if (eq major-mode 'crdt-session-menu-mode)
|
|
(or (tabulated-list-get-id) (signal 'quit nil))
|
|
(if (and crdt--session
|
|
(cl-ecase filter
|
|
((server) (crdt--server-p))
|
|
((client) (not (crdt--server-p)))
|
|
((nil) t)))
|
|
crdt--session
|
|
(or (crdt--read-session filter) (signal 'quit nil)))))
|
|
|
|
(defvar crdt-session-menu-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "RET") #'crdt-list-buffers)
|
|
(define-key map [mouse-1] #'crdt-list-buffers)
|
|
(define-key map (kbd "k") #'crdt--stop-session)
|
|
(define-key map (kbd "d") #'crdt--stop-session)
|
|
map))
|
|
|
|
(define-derived-mode crdt-session-menu-mode tabulated-list-mode
|
|
"CRDT Session List"
|
|
(setq tabulated-list-format [("Session Name" 15 t)
|
|
("Role" 7 t)
|
|
("My Name" 15 t)
|
|
("Buffers" 30 t)
|
|
("Users" 15 t)]))
|
|
|
|
;;;###autoload
|
|
(defun crdt-list-sessions (&optional display-buffer)
|
|
"Display a list of active CRDT sessions.
|
|
If DISPLAY-BUFFER is provided, display the output there."
|
|
(interactive)
|
|
(unless display-buffer
|
|
(unless (and crdt--session-menu-buffer (buffer-live-p crdt--session-menu-buffer))
|
|
(setf crdt--session-menu-buffer
|
|
(generate-new-buffer "*CRDT Sessions*")))
|
|
(setq display-buffer crdt--session-menu-buffer))
|
|
(crdt-refresh-sessions display-buffer)
|
|
(switch-to-buffer-other-window display-buffer))
|
|
|
|
(defun crdt-refresh-sessions (display-buffer)
|
|
"Refresh the CRDT session menu in DISPLAY-BUFFER."
|
|
(with-current-buffer display-buffer
|
|
(crdt-session-menu-mode)
|
|
(setq tabulated-list-entries nil)
|
|
(mapc (lambda (session)
|
|
(push
|
|
(list session (vector (crdt--session-urlstr session)
|
|
(if (crdt--server-p session) "Server" "Client")
|
|
(crdt--session-local-name session)
|
|
(mapconcat (lambda (v) (format "%s" v))
|
|
(hash-table-keys (crdt--session-buffer-table session))
|
|
", ")
|
|
(mapconcat (lambda (v) (format "%s" v))
|
|
(mapcar #'crdt--contact-metadata-name
|
|
(hash-table-values (crdt--session-contact-table session)))
|
|
", ")))
|
|
tabulated-list-entries))
|
|
crdt--session-list)
|
|
(tabulated-list-init-header)
|
|
(tabulated-list-print)))
|
|
|
|
(defsubst crdt--refresh-sessions-maybe ()
|
|
"Refresh the session menu buffer, if there's any."
|
|
(when (and crdt--session-menu-buffer (buffer-live-p crdt--session-menu-buffer))
|
|
(crdt-refresh-sessions crdt--session-menu-buffer)))
|
|
|
|
;;; Buffer menu
|
|
|
|
(defun crdt--read-buffer (session)
|
|
"Prompt for a buffer network name in SESSION."
|
|
(crdt--completing-read
|
|
"Choose a buffer: "
|
|
(hash-table-keys (crdt--session-buffer-table session))
|
|
(when (and (eq crdt--session session)
|
|
crdt--buffer-network-name)
|
|
crdt--buffer-network-name)))
|
|
|
|
(defun crdt--read-buffer-maybe (session)
|
|
"Prompt for a buffer network name in SESSION.
|
|
Directly return the buffer network name under point if in the buffer menu."
|
|
(or (and (eq crdt--session session)
|
|
(if (eq major-mode 'crdt-buffer-menu-mode)
|
|
(or (tabulated-list-get-id) (signal 'quit nil))
|
|
crdt--buffer-network-name))
|
|
(crdt--read-buffer session)
|
|
(signal 'quit nil)))
|
|
|
|
(defun crdt--do-to-buffer (session network-name f)
|
|
"Apply F to buffer with SESSION and NETWORK-NAME."
|
|
(let ((crdt--session session))
|
|
(crdt--with-buffer-name-pull (network-name)
|
|
(funcall f (current-buffer)))))
|
|
|
|
(defun crdt-switch-to-buffer-other-window (session network-name)
|
|
"From the buffer list menu, open buffer with NETWORK-NAME in SESSION."
|
|
(interactive
|
|
(let ((session (crdt--read-session-maybe)))
|
|
(list session (crdt--read-buffer-maybe session))))
|
|
(crdt--do-to-buffer session network-name #'switch-to-buffer-other-window))
|
|
|
|
(defun crdt-switch-to-buffer (session network-name)
|
|
"Switch to buffer with NETWORK-NAME in SESSION."
|
|
(interactive
|
|
(let* ((session (crdt--read-session-maybe))
|
|
(buffers (hash-table-keys (crdt--session-buffer-table session))))
|
|
(list session (completing-read "Choose a buffer: " buffers nil t))))
|
|
(crdt--do-to-buffer session network-name #'switch-to-buffer))
|
|
|
|
(defvar crdt-buffer-menu-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "RET") #'crdt-switch-to-buffer-other-window)
|
|
(define-key map [mouse-1] #'crdt-switch-to-buffer-other-window)
|
|
(define-key map (kbd "k") #'crdt-stop-share-buffer)
|
|
(define-key map (kbd "d") #'crdt-stop-share-buffer)
|
|
map))
|
|
|
|
(define-derived-mode crdt-buffer-menu-mode tabulated-list-mode
|
|
"CRDT Buffer List"
|
|
(setq tabulated-list-format [("Local Buffer" 15 t)
|
|
("Network Name" 30 t)
|
|
("Users" 15 t)]))
|
|
|
|
;;;###autoload
|
|
(defun crdt-list-buffers (&optional session)
|
|
"Display a list of buffers shared in SESSION."
|
|
(interactive (list (crdt--read-session-maybe)))
|
|
(let ((crdt--session (or session crdt--session)))
|
|
(with-current-buffer (current-buffer)
|
|
(unless crdt--session
|
|
(error "Not a CRDT shared buffer"))
|
|
(unless (and (crdt--session-buffer-menu-buffer crdt--session) (buffer-live-p (crdt--session-buffer-menu-buffer crdt--session)))
|
|
(setf (crdt--session-buffer-menu-buffer crdt--session)
|
|
(generate-new-buffer (format "*CRDT Buffers %s*" (crdt--session-urlstr crdt--session))))
|
|
(crdt--assimilate-session (crdt--session-buffer-menu-buffer crdt--session)))
|
|
(let ((display-buffer (crdt--session-buffer-menu-buffer crdt--session)))
|
|
(crdt-refresh-buffers display-buffer)
|
|
(if (crdt--session-network-process crdt--session)
|
|
(switch-to-buffer display-buffer)
|
|
(switch-to-buffer-other-window display-buffer))))))
|
|
|
|
(defun crdt-refresh-buffers (display-buffer)
|
|
"Refresh the CRDT buffer menu in DISPLAY-BUFFER."
|
|
(with-current-buffer display-buffer
|
|
(crdt-buffer-menu-mode)
|
|
(setq tabulated-list-entries nil)
|
|
(let ((tmp-hashtable (make-hash-table :test 'equal)))
|
|
(maphash (lambda (_ v)
|
|
(push (crdt--contact-metadata-name v)
|
|
(gethash (crdt--contact-metadata-focus v)
|
|
tmp-hashtable)))
|
|
(crdt--session-contact-table crdt--session))
|
|
(maphash (lambda (k v)
|
|
(push (list k (vector (if (and v (buffer-live-p v))
|
|
(buffer-name v)
|
|
"--")
|
|
k (mapconcat #'identity (gethash k tmp-hashtable) ", ")))
|
|
tabulated-list-entries))
|
|
(crdt--session-buffer-table crdt--session)))
|
|
(tabulated-list-init-header)
|
|
(tabulated-list-print)))
|
|
|
|
(defsubst crdt--refresh-buffers-maybe ()
|
|
"Refresh the buffer menu buffer for current session, if there's any."
|
|
(when (and (crdt--session-buffer-menu-buffer crdt--session) (buffer-live-p (crdt--session-buffer-menu-buffer crdt--session)))
|
|
(crdt-refresh-buffers (crdt--session-buffer-menu-buffer crdt--session)))
|
|
(crdt--refresh-sessions-maybe))
|
|
|
|
;;; User menu
|
|
|
|
(defun crdt--read-user (session)
|
|
"Prompt for a user name in SESSION."
|
|
(let (candidates)
|
|
(maphash
|
|
(lambda (k v)
|
|
(push (format "%s %s" k (crdt--contact-metadata-name v)) candidates))
|
|
(crdt--session-contact-table session))
|
|
(let ((name
|
|
(crdt--completing-read "Choose a user: " candidates)))
|
|
(string-to-number (car (split-string name))))))
|
|
|
|
(defun crdt--read-user-maybe (session)
|
|
"Prompt for a user name in SESSION.
|
|
Directly return the user name under point if in the user menu."
|
|
(or (and (eq crdt--session session)
|
|
(eq major-mode 'crdt-user-menu-mode)
|
|
(or (tabulated-list-get-id) (signal 'quit nil)))
|
|
(crdt--read-user session)
|
|
(signal 'quit nil)))
|
|
|
|
(defun crdt-goto-user (session user-id)
|
|
"Goto the cursor location of user with USER-ID in SESSION."
|
|
(interactive (let ((session (crdt--read-session-maybe)))
|
|
(list session (crdt--read-user-maybe session))))
|
|
(let ((crdt--session session)
|
|
(switch-window-function
|
|
(if (eq major-mode 'crdt-user-menu-mode) #'switch-to-buffer-other-window #'switch-to-buffer)))
|
|
(if (eq user-id (crdt--session-local-id crdt--session))
|
|
(funcall switch-window-function
|
|
(gethash (crdt--session-focused-buffer-name crdt--session) (crdt--session-buffer-table crdt--session)))
|
|
(unless
|
|
(cl-block nil
|
|
(let* ((metadata (or (gethash user-id (crdt--session-contact-table crdt--session)) (cl-return)))
|
|
(buffer-name (or (crdt--contact-metadata-focus metadata) (cl-return))))
|
|
(crdt--with-buffer-name-pull (buffer-name)
|
|
(funcall switch-window-function (current-buffer))
|
|
(ignore-errors (goto-char (overlay-start (car (gethash user-id crdt--pseudo-cursor-table)))))
|
|
t)))
|
|
(message "Doesn't have position information for this user yet.")))))
|
|
|
|
(defun crdt--session-ensure-user-menu-buffer (session)
|
|
(unless (and (crdt--session-user-menu-buffer session)
|
|
(buffer-live-p (crdt--session-user-menu-buffer session)))
|
|
(setf (crdt--session-user-menu-buffer session)
|
|
(generate-new-buffer (format "*CRDT Users %s*" (crdt--session-urlstr session))))
|
|
(crdt--assimilate-session (crdt--session-user-menu-buffer session))))
|
|
|
|
(defun crdt--cycle-user (&optional prev)
|
|
"Move point in user menu buffer and goto its cursor position.
|
|
If user menu buffer does not exist yet, create it.
|
|
If PREV is non-nil, move backward, otherwise move forward.
|
|
When moving into/out of ourselves, push/pop a global marker instead."
|
|
(unless crdt--session
|
|
(error "Not a CRDT shared buffer"))
|
|
(crdt--session-ensure-user-menu-buffer crdt--session)
|
|
(let* ((mark (point-marker))
|
|
(user-id
|
|
(with-current-buffer (crdt--session-user-menu-buffer crdt--session)
|
|
(when (= (point) (point-max))
|
|
(forward-line -1))
|
|
(when (eq (tabulated-list-get-id) (crdt--session-local-id crdt--session))
|
|
(setf (crdt--session-my-location-marker crdt--session) mark)
|
|
(add-to-history 'global-mark-ring mark global-mark-ring-max t))
|
|
(if prev
|
|
(unless (= (forward-line -1) 0)
|
|
(goto-char (point-max))
|
|
(forward-line -1))
|
|
(forward-line)
|
|
(when (= (point) (point-max))
|
|
(goto-char (point-min))))
|
|
(let ((window (get-buffer-window (current-buffer) t)))
|
|
(when window (set-window-point window (point))))
|
|
(if (eq (tabulated-list-get-id) (crdt--session-local-id crdt--session))
|
|
(when (crdt--session-my-location-marker crdt--session)
|
|
(if (eq (car global-mark-ring) (crdt--session-my-location-marker crdt--session))
|
|
(pop-global-mark)
|
|
(goto-char (crdt--session-my-location-marker crdt--session)))
|
|
nil)
|
|
(tabulated-list-get-id)))))
|
|
(when user-id (crdt-goto-user crdt--session user-id))))
|
|
|
|
(defun crdt-goto-next-user ()
|
|
"Move point in user menu buffer to next user and goto its cursor position.
|
|
If user menu buffer does not exist yet, create it."
|
|
(interactive)
|
|
(crdt--cycle-user))
|
|
|
|
(defun crdt-goto-prev-user ()
|
|
"Move point in user menu buffer to previous user and goto its cursor position.
|
|
If user menu buffer does not exist yet, create it."
|
|
(interactive)
|
|
(crdt--cycle-user t))
|
|
|
|
(defun crdt-kill-user (session user-id)
|
|
"Disconnect the user with USER-ID in SESSION.
|
|
Only server can perform this action."
|
|
(interactive (let ((session (crdt--read-session-maybe 'server)))
|
|
(list session (crdt--read-user-maybe session))))
|
|
(let ((crdt--session session))
|
|
(if (crdt--server-p)
|
|
(if (eq user-id (crdt--session-local-id crdt--session))
|
|
(error "Suicide is not allowed")
|
|
(dolist (p (process-list))
|
|
(when (eq (process-get p 'client-id) user-id)
|
|
(delete-process p))))
|
|
(message "Only server can disconnect a user."))))
|
|
|
|
(defvar crdt-user-menu-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "RET") #'crdt-goto-user)
|
|
(define-key map [mouse-1] #'crdt-goto-user)
|
|
(define-key map (kbd "k") #'crdt-kill-user)
|
|
(define-key map (kbd "d") #'crdt-kill-user)
|
|
(define-key map (kbd "f") #'crdt-follow-user)
|
|
map))
|
|
|
|
(define-derived-mode crdt-user-menu-mode tabulated-list-mode
|
|
"CRDT User List"
|
|
(setq tabulated-list-format [("ID" 7 t)
|
|
("Display Name" 15 t)
|
|
("Follow" 7 t)
|
|
("Focused Buffer" 30 t)]))
|
|
|
|
;;;###autoload
|
|
(defun crdt-list-users (&optional session)
|
|
"Display a list of active users working on a SESSION."
|
|
(interactive (list (crdt--read-session-maybe)))
|
|
(let ((crdt--session session))
|
|
(with-current-buffer (current-buffer)
|
|
(unless crdt--session
|
|
(error "Not a CRDT shared buffer"))
|
|
(crdt--session-ensure-user-menu-buffer crdt--session)
|
|
(let ((display-buffer (crdt--session-user-menu-buffer crdt--session)))
|
|
(crdt-refresh-users display-buffer)
|
|
(switch-to-buffer-other-window display-buffer)))))
|
|
|
|
(defun crdt-refresh-users (display-buffer)
|
|
"Refresh the CRDT user menu in DISPLAY-BUFFER."
|
|
(with-current-buffer display-buffer
|
|
(crdt-user-menu-mode)
|
|
(setq tabulated-list-entries nil)
|
|
(maphash (lambda (k 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))
|
|
colored-name)
|
|
(put-text-property (1- (length colored-name)) (length colored-name)
|
|
'face `(:background ,(crdt--get-cursor-color k))
|
|
colored-name)
|
|
(vector (prin1-to-string k) colored-name
|
|
(if (eq k (crdt--session-follow-user-id crdt--session))
|
|
"yes" "")
|
|
focused-buffer-name))))
|
|
tabulated-list-entries))
|
|
(crdt--session-contact-table crdt--session))
|
|
(tabulated-list-init-header)
|
|
(tabulated-list-print)))
|
|
|
|
(defsubst crdt--refresh-users-maybe ()
|
|
"Refresh the user menu buffer for current session, if there's any.
|
|
This function also calls `crdt--refresh-buffers-maybe', as changes in
|
|
user menu almost always indicate supposed changes in buffer menu."
|
|
(when (and (crdt--session-user-menu-buffer crdt--session) (buffer-live-p (crdt--session-user-menu-buffer crdt--session)))
|
|
(crdt-refresh-users (crdt--session-user-menu-buffer crdt--session)))
|
|
(crdt--refresh-buffers-maybe))
|
|
|
|
(defun crdt-follow-user (session user-id)
|
|
"Toggle following user with USER-ID in SESSION."
|
|
(interactive (let ((session (crdt--read-session-maybe)))
|
|
(list session (crdt--read-user-maybe session))))
|
|
(let ((crdt--session session))
|
|
(if (eq user-id (crdt--session-local-id crdt--session))
|
|
(error "Narcissism is not allowed")
|
|
(if (eq user-id (crdt--session-follow-user-id crdt--session))
|
|
(crdt-stop-follow)
|
|
(setf (crdt--session-follow-user-id crdt--session) user-id))
|
|
(crdt--refresh-users-maybe))))
|
|
|
|
(defun crdt-stop-follow ()
|
|
"Stop following user if any."
|
|
(interactive)
|
|
(message "Stop following %s."
|
|
(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)
|
|
(crdt--refresh-users-maybe))
|
|
|
|
(defun crdt--kill-buffer-hook ()
|
|
"Kill buffer hook for CRDT shared buffers.
|
|
It informs other peers that the buffer is killed."
|
|
(when crdt--buffer-network-name
|
|
(puthash crdt--buffer-network-name nil (crdt--session-buffer-table crdt--session))
|
|
(crdt--broadcast-maybe (crdt--format-message
|
|
`(cursor ,crdt--buffer-network-name
|
|
,(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
|
|
`(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))
|
|
(crdt--refresh-users-maybe)))
|
|
|
|
;;; Capabilities
|
|
|
|
(define-error 'crdt-invalid-fcap "Invalid CRDT fcap")
|
|
(define-error 'crdt-no-permission "No CRDT permission")
|
|
|
|
(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 (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
|
|
(name &optional in-states out-states (proxy name))
|
|
"Return a new `crdt-local-fcap'.
|
|
The fcap is initialized with NAME, IN-STATES, OUT-STATES and PROXY.
|
|
When PROXY is nil, use NAME by default."
|
|
(crdt--make-local-fcap name nil in-states out-states proxy))
|
|
|
|
(defun crdt-make-local-fcaps (fcap-entries)
|
|
"Return a list of new `crdt-local-fcap'.
|
|
FCAP-ENTRIES should be a list with each element a valid lists
|
|
of arguments to `crdt-make-local-fcap'.
|
|
See `crdt-xscheme-fcaps' for an example of usage."
|
|
(mapcar (lambda (entry) (apply #'crdt-make-local-fcap entry))
|
|
fcap-entries))
|
|
|
|
(defun crdt--generate-nonce ()
|
|
(with-temp-buffer
|
|
(toggle-enable-multibyte-characters 0)
|
|
(let ((err (call-process-shell-command "head -c 16 /dev/urandom" nil t)))
|
|
(unless (= err 0)
|
|
(error "Failed to read /dev/urandom (code %s)" err)))
|
|
(buffer-string)))
|
|
|
|
(defun crdt--compute-user-fcaps (permission user-id)
|
|
(cl-loop for f in permission
|
|
if (functionp f)
|
|
append (funcall f user-id)
|
|
else if (symbolp f)
|
|
append (symbol-value f)
|
|
else
|
|
append f))
|
|
|
|
(defun crdt--intern-fcap (fcap)
|
|
"Copy FCAP to current session's local fcap table.
|
|
Generate a nonce if none has been generated before."
|
|
(let ((memo (gethash (crdt-local-fcap-name fcap)
|
|
(crdt--session-local-fcap-table crdt--session)))
|
|
(fcap (cl-copy-seq fcap)))
|
|
(setf (crdt-local-fcap-nonce fcap)
|
|
(if memo (crdt-local-fcap-nonce memo) (crdt--generate-nonce)))
|
|
(puthash (crdt-local-fcap-name fcap) fcap
|
|
(crdt--session-local-fcap-table crdt--session))
|
|
fcap))
|
|
|
|
(defun crdt-make-interactive-proxy (command-symbol)
|
|
"Return a function that calls COMMAND-SYMBOL interactively on remote machine."
|
|
(lambda () (interactive)
|
|
(let ((this-command command-symbol))
|
|
(call-interactively command-symbol))))
|
|
|
|
(defun crdt-get-write-access ()
|
|
"Allocate a Site ID for current user to access current buffer.
|
|
Current user means the user corresponding to CRDT--PROCESS."
|
|
(let (new-site-id)
|
|
(cl-loop
|
|
for i in crdt--site-id-list
|
|
for c on crdt--site-id-list
|
|
for j in (cdr crdt--site-id-list)
|
|
if (> j (1+ i))
|
|
do (progn
|
|
(setq new-site-id (1+ i))
|
|
(push (1+ i) (cdr c))
|
|
(cl-return)))
|
|
(unless new-site-id
|
|
(let* ((cons (last crdt--site-id-use-list 2))
|
|
(victim-id (cadr cons)))
|
|
;; todo: notify the victim
|
|
(rplacd cons nil)
|
|
(setq new-site-id victim-id)))
|
|
(push new-site-id crdt--site-id-use-list)
|
|
(puthash (crdt--client-id) new-site-id crdt--site-id-table)
|
|
new-site-id))
|
|
|
|
(defvar crdt-write-access-fcaps
|
|
(crdt-make-local-fcaps '((crdt-get-write-access (buffer)))))
|
|
|
|
(defun crdt-get-buffer-create (network-name)
|
|
"Return the buffer with NETWORK-NAME, creating a new one if needed."
|
|
(or (gethash network-name (crdt--session-buffer-table crdt--session))
|
|
(crdt--share-buffer (generate-new-buffer network-name)
|
|
crdt--session network-name)))
|
|
|
|
(defvar crdt-create-buffer-fcaps
|
|
(crdt-make-local-fcaps '((crdt-get-buffer-create))))
|
|
|
|
;;; CRDT insert/delete
|
|
|
|
(defsubst crdt--text-property-assimilate
|
|
(template template-beg template-end beg prop &optional object)
|
|
"Make PROP after BEG in OBJECT the same as part of TEMPLATE.
|
|
The part between TEMPLATE-BEG and TEMPLATE-END is used.
|
|
If OBJECT is NIL, use current buffer."
|
|
(let (next-pos
|
|
(pos template-beg)
|
|
(limit template-end)
|
|
(offset (- beg template-beg)))
|
|
(while (< pos limit)
|
|
(setq next-pos (next-single-property-change pos prop template limit))
|
|
(put-text-property (+ offset pos) (+ offset next-pos) prop
|
|
(get-text-property pos prop template)
|
|
object)
|
|
(setq pos next-pos))))
|
|
|
|
(defsubst crdt--buffer-substring (beg end)
|
|
"Return the contents between BEG and END of the current buffer as a string.
|
|
Copies text properties in CRDT--ENABLED-TEXT-PROPERTIES."
|
|
(let ((string (buffer-substring-no-properties beg end)))
|
|
(dolist (prop crdt--enabled-text-properties)
|
|
(crdt--text-property-assimilate nil beg end 0 prop string))
|
|
string))
|
|
|
|
(defun crdt--local-insert (beg end)
|
|
"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
|
|
(crdt--visualize-author-1 beg end user-id))
|
|
(let (resulting-fcaps)
|
|
(crdt--with-insertion-information (beg end)
|
|
(unless (crdt--split-maybe)
|
|
(when (and not-begin
|
|
(eq (crdt--id-site starting-id) (crdt--session-local-id crdt--session))
|
|
(crdt--end-of-block-p left-pos))
|
|
;; merge crdt id block
|
|
(let* ((max-offset crdt--max-value)
|
|
(merge-end (min end (+ (- max-offset left-offset 1) beg))))
|
|
(unless (= merge-end beg)
|
|
(put-text-property beg merge-end 'crdt-id starting-id-pair)
|
|
(let ((virtual-id (substring starting-id)))
|
|
(crdt--set-id-offset virtual-id (1+ left-offset))
|
|
(push `(insert ,crdt--buffer-network-name ,user-id
|
|
,virtual-id ,beg
|
|
,(crdt--buffer-substring beg merge-end))
|
|
resulting-fcaps))
|
|
(cl-incf left-offset (- merge-end beg))
|
|
(setq beg merge-end)))))
|
|
(while (< beg end)
|
|
(let ((block-end (min end (+ crdt--max-value beg))))
|
|
(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--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
|
|
,(crdt--buffer-substring beg block-end))
|
|
resulting-fcaps)
|
|
(setq beg block-end)
|
|
(setq left-offset (1- crdt--max-value)) ; this is always true when we need to continue
|
|
(setq starting-id new-id)))))
|
|
;; (crdt--verify-buffer)
|
|
(nreverse resulting-fcaps))))
|
|
|
|
(defun crdt--find-id (id pos &optional before)
|
|
"Find the first position *after* ID if BEFORE is NIL or *before* ID otherwise.
|
|
Start the search from POS.
|
|
This function doesn't handle empty string convention in the crdt.el protocol.
|
|
To convert an ID in protocol message to a position in the buffer,
|
|
CRDT--ID-TO-POS is usually more appropriate."
|
|
(let* ((left-pos (previous-single-property-change (min (1+ pos) (point-max))
|
|
'crdt-id nil (point-min)))
|
|
(left-id (crdt--get-starting-id left-pos))
|
|
(right-pos (next-single-property-change (min pos (point-max)) 'crdt-id nil (point-max)))
|
|
(right-id (crdt--get-starting-id right-pos))
|
|
(moving-forward nil))
|
|
(cl-macrolet ((move-forward ()
|
|
'(progn
|
|
(setq moving-forward t)
|
|
(setq left-pos right-pos)
|
|
(setq left-id right-id)
|
|
(setq right-pos (next-single-property-change right-pos 'crdt-id nil (point-max)))
|
|
(setq right-id (crdt--get-starting-id right-pos))))
|
|
(move-backward ()
|
|
'(progn
|
|
(setq moving-forward nil)
|
|
(setq right-pos left-pos)
|
|
(setq right-id left-id)
|
|
(setq left-pos (previous-single-property-change left-pos 'crdt-id nil (point-min)))
|
|
(setq left-id (crdt--get-starting-id left-pos)))))
|
|
(cl-block nil
|
|
(while t
|
|
(cond ((<= right-pos (point-min))
|
|
(cl-return (point-min)))
|
|
((>= left-pos (point-max))
|
|
(cl-return (point-max)))
|
|
((and right-id (not (string< id right-id)))
|
|
(move-forward))
|
|
((not left-id)
|
|
(if moving-forward
|
|
(move-forward)
|
|
(move-backward)))
|
|
((string< id left-id)
|
|
(move-backward))
|
|
(t
|
|
;; will unibyte to multibyte conversion cause any problem?
|
|
(cl-return
|
|
(if (eq t (compare-strings left-id 0 (- (string-bytes left-id) 2)
|
|
id 0 (- (string-bytes left-id) 2)))
|
|
(min right-pos (+ left-pos (if before 0 1)
|
|
(- (crdt--get-two-bytes id (- (string-bytes left-id) 2))
|
|
(crdt--id-offset left-id))))
|
|
right-pos)))))))))
|
|
|
|
(defun crdt--remote-insert (id user-id position-hint content)
|
|
"Handle remote insert message that CONTENT should be insert.
|
|
The first character of CONTENT has CRDT ID.
|
|
Start the search around POSITION-HINT.
|
|
Mark the insertion as authored by USER-ID."
|
|
(let* ((beg (crdt--find-id id position-hint)) end)
|
|
(save-excursion
|
|
(goto-char beg)
|
|
(insert (propertize content 'crdt-author user-id))
|
|
(setq end (point))
|
|
(when crdt-visualize-author-mode
|
|
(crdt--visualize-author-1 beg end (crdt--id-site id)))
|
|
;; work around for input method overlays
|
|
(cl-loop for ov in (overlays-at beg)
|
|
do (unless (or (overlay-get ov 'crdt-meta)
|
|
(memq (overlay-get ov 'category)
|
|
'(crdt-visualize-author crdt-pseudo-cursor)))
|
|
(when (eq (overlay-start ov) beg)
|
|
(move-overlay ov end (overlay-end ov)))))
|
|
(with-silent-modifications
|
|
(let ((real-end end))
|
|
(unless (get-text-property end 'crdt-id)
|
|
(setq end (next-single-property-change end 'crdt-id nil (point-max))))
|
|
(crdt--with-insertion-information (beg end)
|
|
(let ((base-length (- (string-bytes starting-id) 2)))
|
|
(if (and (eq (string-bytes id) (string-bytes starting-id))
|
|
(eq t (compare-strings starting-id 0 base-length
|
|
id 0 base-length))
|
|
(eq (1+ left-offset) (crdt--id-offset id)))
|
|
(put-text-property beg real-end 'crdt-id starting-id-pair)
|
|
(put-text-property beg real-end 'crdt-id (cons id t))))
|
|
(crdt--split-maybe))))))
|
|
;; (crdt--verify-buffer)
|
|
)
|
|
|
|
(defsubst crdt--changed-string (beg length)
|
|
"Retrieve part of CRDT--CHANGED-STRING starting at BEG with LENGTH before change."
|
|
(let ((from (- beg crdt--changed-start)))
|
|
(substring crdt--changed-string from (+ from length))))
|
|
|
|
(defun crdt--local-delete (beg end length)
|
|
"Handle local deletion event and return a message to be sent to other peers.
|
|
The deletion happens between BEG and END, and have LENGTH."
|
|
(let ((outer-end end)
|
|
(crdt--changed-string (crdt--changed-string beg length)))
|
|
(crdt--with-insertion-information (beg 0 nil crdt--changed-string nil (length crdt--changed-string))
|
|
(when (crdt--split-maybe)
|
|
(let* ((not-end (< outer-end (point-max)))
|
|
(ending-id (when not-end (crdt--get-starting-id outer-end))))
|
|
(when (and not-end (eq starting-id (crdt--get-starting-id outer-end)))
|
|
(crdt--set-id outer-end
|
|
(crdt--id-replace-offset ending-id (+ 1 left-offset (length crdt--changed-string))))))))
|
|
(crdt--with-insertion-information ((length crdt--changed-string) outer-end crdt--changed-string nil 0 nil)
|
|
(crdt--split-maybe))
|
|
;; (crdt--verify-buffer)
|
|
`(delete ,crdt--buffer-network-name ,(crdt--session-local-id crdt--session)
|
|
,beg ,@ (crdt--dump-ids 0 (length crdt--changed-string) crdt--changed-string t))))
|
|
|
|
(defun crdt--remote-delete (position-hint id-items)
|
|
"Handle remote deletion message of ID-ITEMS.
|
|
ID-ITEMS should be a list of CONSes of the form (LENGTH . STARTING-ID).
|
|
Start the search for those ID-ITEMs around POSITION-HINT."
|
|
(save-excursion
|
|
(dolist (id-item id-items)
|
|
(cl-destructuring-bind (length id) id-item
|
|
(while (> length 0)
|
|
(goto-char (crdt--find-id id position-hint t))
|
|
(let* ((end-of-block (next-single-property-change (point) 'crdt-id nil (point-max)))
|
|
(block-length (- end-of-block (point))))
|
|
(cl-case (cl-signum (- length block-length))
|
|
((1) (delete-char block-length)
|
|
(cl-decf length block-length)
|
|
(crdt--set-id-offset id (+ (crdt--id-offset id) block-length)))
|
|
((0) (delete-char length)
|
|
(setq length 0))
|
|
((-1)
|
|
(let* ((starting-id (crdt--get-starting-id (point)))
|
|
(eob (crdt--end-of-block-p (point)))
|
|
(left-offset (crdt--get-id-offset starting-id (point))))
|
|
(delete-char length)
|
|
(crdt--set-id (point) (crdt--id-replace-offset starting-id (+ left-offset length)) eob))
|
|
(setq length 0)))))
|
|
;; (crdt--verify-buffer)
|
|
))))
|
|
|
|
(defun crdt--before-change (beg end)
|
|
"Before change hook used by CRDT-MODE.
|
|
Save the content to be changed (between BEG and END) into CRDT--CHANGED-STRING.
|
|
Request a Site ID if we don't have it yet."
|
|
(unless crdt--inhibit-update
|
|
(setq crdt--changed-string (crdt--buffer-substring beg end))
|
|
(crdt--text-property-assimilate nil beg end 0
|
|
'crdt-id crdt--changed-string)
|
|
(setq crdt--changed-start beg)
|
|
(unless crdt--site-id
|
|
(condition-case nil
|
|
(setq crdt--site-id
|
|
(crdt-remote-apply (crdt-get-fcap 'crdt-get-write-access) nil))
|
|
(crdt-invalid-fcap
|
|
(read-only-mode)
|
|
(warn "Write access revoked in %s" crdt--buffer-network-name)
|
|
(signal 'quit nil))))))
|
|
|
|
(defsubst crdt--crdt-id-assimilate (template beg &optional object)
|
|
"Make the CRDT-ID property after BEG in OBJECT the same as TEMPLATE.
|
|
TEMPLATE should be a string. If OBJECT is NIL, use current buffer."
|
|
(crdt--text-property-assimilate template 0 (length template) beg 'crdt-id object))
|
|
|
|
(defun crdt--after-change (beg end length)
|
|
"After change hook used by CRDT-MODE.
|
|
It examine (CRDT--CHANGED-STRING) (should be saved by CRDT--BEFORE-STRING)
|
|
and current content between BEG and END with LENGTH,
|
|
update the CRDT-ID for any newly inserted text, and send message to other peers if needed."
|
|
(crdt--with-should-not-error 'crdt--after-change
|
|
(when (markerp beg)
|
|
(setq beg (marker-position beg)))
|
|
(when (markerp end)
|
|
(setq end (marker-position end)))
|
|
(mapc (lambda (ov)
|
|
(when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor)
|
|
(crdt--move-cursor ov beg)))
|
|
(overlays-in beg (min (point-max) (1+ beg))))
|
|
(when (crdt--session-local-id crdt--session)
|
|
(unless crdt--inhibit-update
|
|
(let ((crdt--inhibit-update t))
|
|
;; we're only interested in text change
|
|
;; ignore property only changes
|
|
;; todo: track properties in crdt--enabled-text-properties
|
|
(save-excursion
|
|
(save-restriction
|
|
(goto-char beg)
|
|
(if (and (= length (- end beg))
|
|
(equal-including-properties (crdt--changed-string beg length)
|
|
(crdt--buffer-substring beg end)))
|
|
(crdt--crdt-id-assimilate (crdt--changed-string beg length) beg)
|
|
(widen)
|
|
(with-silent-modifications
|
|
(unless (= length 0)
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message (crdt--local-delete beg end length))))
|
|
(unless (= beg end)
|
|
(dolist (message (crdt--local-insert beg end))
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message message))))))))
|
|
;; see if region stuff changed
|
|
(let ((cursor-message (crdt--local-cursor)))
|
|
(when cursor-message
|
|
(crdt--broadcast-maybe (crdt--format-message cursor-message))))
|
|
;; process-mark synchronization is dependent on correct CRDT-ID
|
|
;; therefore we must do it after the insert/change stuff is done
|
|
(crdt--send-process-mark-maybe)
|
|
(crdt--send-variables-maybe))))))
|
|
|
|
;;; CRDT point/mark synchronization
|
|
|
|
(defsubst crdt--id-to-pos (id hint)
|
|
"Convert CRDT-ID ID to a position in current buffer with best effort.
|
|
Start the search around HINT."
|
|
(if (> (string-bytes id) 0)
|
|
(crdt--find-id id hint t)
|
|
(point-max)))
|
|
|
|
(defun crdt--remote-cursor (user-id point-position-hint point-crdt-id mark-position-hint mark-crdt-id)
|
|
"Handle remote cursor/mark movement message at USER-ID.
|
|
The cursor for that site is at POINT-CRDT-ID,
|
|
whose search starts around POINT-POSITION-HINT.
|
|
If POINT-CRDT-ID is NIL, remove the pseudo cursor and region
|
|
overlays for this site.
|
|
The mark for that site is at MARK-CRDT-ID,
|
|
whose search starts around MARK-POSITION-HINT.
|
|
If MARK-CRDT-ID is NIL, deactivate the pseudo region overlay."
|
|
(when (and user-id (not (eq user-id (crdt--session-local-id crdt--session))))
|
|
(let ((ov-pair (gethash user-id crdt--pseudo-cursor-table)))
|
|
(if point-crdt-id
|
|
(let* ((point (crdt--id-to-pos point-crdt-id point-position-hint))
|
|
(mark (if mark-crdt-id
|
|
(crdt--id-to-pos mark-crdt-id mark-position-hint)
|
|
point)))
|
|
(unless ov-pair
|
|
(let ((new-cursor (make-overlay 1 1))
|
|
(new-region (make-overlay 1 1)))
|
|
(overlay-put new-cursor 'face `(:background ,(crdt--get-cursor-color user-id)))
|
|
(overlay-put new-cursor 'category 'crdt-pseudo-cursor)
|
|
(overlay-put new-region 'face `(:background ,(crdt--get-region-color user-id) :extend t))
|
|
(setq ov-pair (puthash user-id (cons new-cursor new-region)
|
|
crdt--pseudo-cursor-table))))
|
|
(crdt--move-cursor (car ov-pair) point)
|
|
(crdt--move-region (cdr ov-pair) point mark)
|
|
(when (eq user-id (crdt--session-follow-user-id crdt--session))
|
|
(goto-char point)
|
|
(let ((cursor-message (crdt--local-cursor)))
|
|
(when cursor-message
|
|
(crdt--broadcast-maybe (crdt--format-message cursor-message))))))
|
|
(when ov-pair
|
|
(remhash user-id crdt--pseudo-cursor-table)
|
|
(delete-overlay (car ov-pair))
|
|
(delete-overlay (cdr ov-pair)))))))
|
|
|
|
(cl-defun crdt--local-cursor (&optional (lazy t))
|
|
"Handle local cursor/mark movement event.
|
|
If LAZY if T, return NIL if cursor/mark doesn't move
|
|
since last call of this function.
|
|
Always return a message otherwise."
|
|
(let ((point (point))
|
|
(mark (when (use-region-p) (mark))))
|
|
(unless (and lazy
|
|
(eq point crdt--last-point)
|
|
(eq mark crdt--last-mark))
|
|
(when (or (eq point (point-max)) (eq crdt--last-point (point-max)))
|
|
(mapc (lambda (ov)
|
|
(when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor)
|
|
(crdt--move-cursor ov (point-max))))
|
|
(overlays-in (point-max) (point-max))))
|
|
(setq crdt--last-point point)
|
|
(setq crdt--last-mark mark)
|
|
(save-restriction
|
|
(widen)
|
|
`(cursor ,crdt--buffer-network-name ,(crdt--session-local-id crdt--session)
|
|
,point ,(crdt--get-id point) ,mark ,(when mark (crdt--get-id mark)))))))
|
|
|
|
(defun crdt--post-command ()
|
|
"Post command hook used by CRDT-MODE.
|
|
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 `(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)))
|
|
(when cursor-message
|
|
(crdt--broadcast-maybe (crdt--format-message cursor-message))))
|
|
;; process-mark synchronization is dependent on correct CRDT-ID
|
|
;; therefore we must do it after the insert/change stuff is done
|
|
(crdt--send-process-mark-maybe)
|
|
(crdt--send-variables-maybe)))
|
|
|
|
;;; CRDT ID (de)serialization
|
|
|
|
(defun crdt--dump-ids (beg end object &optional omit-end-of-block-p include-content)
|
|
"Serialize all CRDT IDs in OBJECT from BEG to END into a list.
|
|
The list contains CONSes of the form (LENGTH CRDT-ID END-OF-BLOCK-P),
|
|
or (LENGTH CRDT-ID) if OMIT-END-OF-BLOCK-P is non-NIL,
|
|
in the order that they appears in the document.
|
|
If INCLUDE-CONTENT is non-NIL, the list contains STRING instead of LENGTH."
|
|
(let (ids (pos end))
|
|
(while (> pos beg)
|
|
(let ((prev-pos (previous-single-property-change pos 'crdt-id object beg)))
|
|
(when (crdt--get-crdt-id-pair prev-pos object)
|
|
(push (cons (if include-content
|
|
(cond ((not object) (crdt--buffer-substring prev-pos pos))
|
|
((bufferp object)
|
|
(with-current-buffer object
|
|
(crdt--buffer-substring prev-pos pos)))
|
|
(t (substring object prev-pos pos)))
|
|
(- pos prev-pos))
|
|
(cl-destructuring-bind (id . eob) (crdt--get-crdt-id-pair prev-pos object)
|
|
(if omit-end-of-block-p (list id) (list id eob))))
|
|
ids))
|
|
(setq pos prev-pos)))
|
|
ids))
|
|
|
|
(defun crdt--load-ids (ids)
|
|
"Load the CRDT ids in IDS (generated by CRDT--DUMP-IDS)
|
|
into current buffer."
|
|
(goto-char (point-min))
|
|
(dolist (id-item ids)
|
|
(cl-destructuring-bind (content id eob) id-item
|
|
(insert (propertize content 'crdt-id (cons id eob))))))
|
|
|
|
(defun crdt--verify-buffer ()
|
|
"Debug helper function.
|
|
Verify that CRDT IDs in a document follows ascending order."
|
|
(let* ((pos (point-min))
|
|
(id (crdt--get-starting-id pos)))
|
|
(cl-block nil
|
|
(while t
|
|
(let* ((next-pos (next-single-property-change pos 'crdt-id))
|
|
(next-id (if (< next-pos (point-max))
|
|
(crdt--get-starting-id next-pos)
|
|
(cl-return)))
|
|
(prev-id (substring id)))
|
|
(crdt--set-id-offset id (+ (- next-pos pos) (crdt--id-offset id)))
|
|
(unless (string< prev-id next-id)
|
|
(error "Not monotonic!"))
|
|
(setq pos next-pos)
|
|
(setq id next-id))))))
|
|
|
|
;;; Network protocol
|
|
|
|
(defun crdt--format-message (args)
|
|
"Serialize ARGS (which should be a list) into a string.
|
|
Return the string."
|
|
(let ((print-level nil)
|
|
(print-length nil))
|
|
(prin1-to-string args)))
|
|
|
|
(cl-defun crdt--readable-encode (object &optional (no-properties t))
|
|
"Return an object ``similar'' to OBJECT at best effort.
|
|
If NO-PROPERTIES is non-nil,
|
|
omit text properties of any strings in the returned object.
|
|
The returned object has a printed representation that can be read back.
|
|
The symbol CRDT-EVAL is used as an special marker in the encoding
|
|
and the behavior is undefined if OBJECT itself contains this symbol."
|
|
(cl-typecase object
|
|
(string (if no-properties (substring-no-properties object) object))
|
|
((or symbol number character) object)
|
|
(vector (cl-map 'vector #'crdt--readable-encode object))
|
|
(cons (cons (crdt--readable-encode (car object)) (crdt--readable-encode (cdr object))))
|
|
(buffer (list 'crdt-eval 'buffer
|
|
(buffer-local-value 'crdt--buffer-network-name object)))
|
|
(t (list 'crdt-eval 'unreadable
|
|
(prin1-to-string object)))))
|
|
|
|
(defun crdt--readable-decode (object)
|
|
"Reconstruct the original object from CRDT--READABLE-ENCODEd OBJECT at best effort."
|
|
(cl-typecase object
|
|
(cons (if (eq (car object) 'crdt-eval)
|
|
(cl-case (cadr object)
|
|
((buffer) (crdt--with-buffer-name (caddr object) (current-buffer)))
|
|
((unreadable) (caddr object)))
|
|
(cons (crdt--readable-decode (car object)) (crdt--readable-decode (cdr object)))))
|
|
(vector (cl-map 'vector #'crdt--readable-decode object))
|
|
(t object)))
|
|
|
|
(defsubst crdt--log-send-network-traffic (message-string)
|
|
(when crdt--log-network-traffic
|
|
(message "Send %s" message-string)))
|
|
|
|
(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 (process-contact (crdt--session-network-process crdt--session) :server)
|
|
(dolist (client (crdt--session-network-clients crdt--session))
|
|
(when (and (eq (process-status client) 'open)
|
|
(not (eq (process-get client 'client-id) without)))
|
|
(crdt--log-send-network-traffic message-string)
|
|
(process-send-string client message-string)
|
|
;; (run-at-time 1 nil #'process-send-string client message-string)
|
|
;; ^ quick dirty way to simulate network latency, for debugging
|
|
))
|
|
(when without
|
|
(crdt--log-send-network-traffic message-string)
|
|
(process-send-string (crdt--session-network-process crdt--session) message-string)
|
|
;; (run-at-time 1 nil #'process-send-string (crdt--session-network-process crdt--session) message-string)
|
|
)))
|
|
|
|
(defvar crdt--message-handler-table (make-hash-table)
|
|
"Map CRDT message type to handler function.")
|
|
|
|
(cl-defmacro define-crdt-message-handler (type arglist &body body)
|
|
"Define a crdt message handler.
|
|
Define a function CRDT--HANDLE-MESSAGE-[TYPE] with ARGLIST and BODY and
|
|
use it to handle message TYPE."
|
|
(declare (debug
|
|
(&define name cl-lambda-list cl-declarations-or-string def-body))
|
|
(doc-string 3)
|
|
(indent 2))
|
|
(let ((function-name (intern (concat "crdt--handle-message-" (symbol-name type)))))
|
|
`(progn
|
|
(cl-defun ,function-name ,arglist ,@body)
|
|
(puthash ',type ',function-name crdt--message-handler-table))))
|
|
|
|
(defvar crdt--message-string nil
|
|
"Bound to the string representation of the message inside message handler.
|
|
So that we don't need to convert MESSAGE to string again
|
|
when we need to broadcast it.")
|
|
|
|
(define-error 'crdt-unrecognized-message "Unhandled crdt-unrecognized-message.")
|
|
|
|
(defsubst crdt-process-message (message string)
|
|
(let ((crdt--message-string string))
|
|
(let ((handler (gethash (car message) crdt--message-handler-table)))
|
|
(if handler
|
|
(apply handler (cdr message))
|
|
(message "Unrecognized message %S from %s:%s."
|
|
message (process-contact crdt--process :host) (process-contact crdt--process :service))
|
|
(signal 'crdt-unrecognized-message nil)))))
|
|
|
|
(defsubst crdt-process-message-1 (message)
|
|
(crdt-process-message message (crdt--format-message message)))
|
|
|
|
(defsubst crdt--overlay-add-message (id clock species front-advance rear-advance beg end)
|
|
"Create an overlay-add message to be sent to peers.
|
|
The overlay is generated at site with ID and logical CLOCK.
|
|
The overlay is categorized as SPECIES.
|
|
The overlay is FRONT-ADVANCE and REAR-ADVANCE, and lies between BEG and END."
|
|
`(overlay-add ,crdt--buffer-network-name ,id ,clock
|
|
,species ,front-advance ,rear-advance
|
|
,beg ,(if front-advance
|
|
(crdt--get-id beg)
|
|
(crdt--get-id (1- beg)))
|
|
,end ,(if rear-advance
|
|
(crdt--get-id end)
|
|
(crdt--get-id (1- end)))))
|
|
|
|
(defsubst crdt--generate-challenge ()
|
|
"Generate a challenge string for authentication."
|
|
(apply #'unibyte-string (cl-loop for i below 32 collect (random 256))))
|
|
|
|
(defsubst crdt--sync-buffer-to-client (buffer)
|
|
"Send messages to a client about the full state of BUFFER.
|
|
CRDT--PROCESS should be bound to the network process for the client connection."
|
|
(with-current-buffer buffer
|
|
(save-restriction
|
|
(widen)
|
|
(process-send-string crdt--process
|
|
(crdt--format-message
|
|
`(sync
|
|
,crdt--buffer-network-name
|
|
,@ (crdt--dump-ids (point-min) (point-max) nil nil t))))
|
|
(process-send-string crdt--process (crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode)))
|
|
|
|
;; synchronize cursor
|
|
(maphash (lambda (user-id ov-pair)
|
|
(cl-destructuring-bind (cursor-ov . region-ov) ov-pair
|
|
(let* ((point (overlay-start cursor-ov))
|
|
(region-beg (overlay-start region-ov))
|
|
(region-end (overlay-end region-ov))
|
|
(mark (if (eq point region-beg)
|
|
(unless (eq point region-end) region-end)
|
|
region-beg)))
|
|
(process-send-string crdt--process
|
|
(crdt--format-message
|
|
`(cursor ,crdt--buffer-network-name ,user-id
|
|
,point ,(crdt--get-id point)
|
|
,mark ,(when mark (crdt--get-id mark))))))))
|
|
crdt--pseudo-cursor-table)
|
|
(process-send-string crdt--process (crdt--format-message (crdt--local-cursor nil)))
|
|
|
|
;; synchronize tracked overlay
|
|
(maphash (lambda (k ov)
|
|
(let ((meta (overlay-get ov 'crdt-meta)))
|
|
(process-send-string
|
|
crdt--process
|
|
(crdt--format-message (crdt--overlay-add-message
|
|
(car k) (cdr k)
|
|
(crdt--overlay-metadata-species meta)
|
|
(crdt--overlay-metadata-front-advance meta)
|
|
(crdt--overlay-metadata-rear-advance meta)
|
|
(overlay-start ov)
|
|
(overlay-end ov))))
|
|
(cl-loop for (prop value) on (crdt--overlay-metadata-plist meta) by #'cddr
|
|
do (process-send-string
|
|
crdt--process
|
|
(crdt--format-message `(overlay-put ,crdt--buffer-network-name
|
|
,(car k) ,(cdr k) ,prop ,value))))))
|
|
crdt--overlay-table)
|
|
|
|
(crdt--send-process-mark-maybe nil)
|
|
(crdt--send-variables-maybe nil))))
|
|
|
|
(defun crdt--greet-client ()
|
|
"Send initial information when a client connects.
|
|
Those information include the assigned USER-ID, buffer list,
|
|
and contact data of other users.
|
|
CRDT--PROCESS should be bound to The network process for the client connection."
|
|
(let ((crdt--session (process-get crdt--process 'crdt-session)))
|
|
(cl-pushnew crdt--process (crdt--session-network-clients crdt--session))
|
|
(let ((client-id (process-get crdt--process 'client-id)))
|
|
(unless client-id
|
|
(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)))
|
|
(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)
|
|
(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))
|
|
;; send fcaps
|
|
(dolist (fcap (crdt--compute-user-fcaps
|
|
(crdt--session-permissions crdt--session)
|
|
client-id))
|
|
(setq fcap (crdt--intern-fcap fcap))
|
|
(process-send-string crdt--process
|
|
(crdt--format-message
|
|
`(fcap ,(crdt-local-fcap-name fcap)
|
|
,(crdt-local-fcap-nonce fcap)
|
|
,(crdt-local-fcap-in-states fcap)
|
|
,(crdt-local-fcap-out-states fcap)
|
|
,@ (interactive-form (crdt-local-fcap-proxy fcap)))))))))
|
|
|
|
(define-crdt-message-handler insert (buffer-name user-id crdt-id position-hint content)
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(crdt--remote-insert crdt-id user-id position-hint content)))
|
|
(crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
|
|
|
|
(define-crdt-message-handler delete (buffer-name _user-id position-hint . id-pairs)
|
|
(mapc (lambda (p) (rplaca (cdr p) (cadr p))) id-pairs)
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(crdt--remote-delete position-hint id-pairs)))
|
|
(crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
|
|
|
|
(define-crdt-message-handler cursor
|
|
(buffer-name user-id point-position-hint point-crdt-id mark-position-hint mark-crdt-id)
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(crdt--remote-cursor user-id point-position-hint point-crdt-id
|
|
mark-position-hint mark-crdt-id)))
|
|
(crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
|
|
|
|
(define-crdt-message-handler get (buffer-name)
|
|
(let ((buffer (gethash buffer-name (crdt--session-buffer-table crdt--session))))
|
|
(if (and buffer (buffer-live-p buffer))
|
|
(crdt--sync-buffer-to-client buffer)
|
|
(process-send-string crdt--process (crdt--format-message `(remove ,buffer-name))))))
|
|
|
|
(define-crdt-message-handler sync (buffer-name . ids)
|
|
(unless (crdt--server-p) ; server shouldn't receive this
|
|
(crdt--with-buffer-name buffer-name
|
|
(let ((crdt--inhibit-update t)
|
|
(inhibit-read-only t))
|
|
(unless crdt--buffer-sync-callback
|
|
;; try to get to the same position after sync,
|
|
;; if crdt--buffer-sync-callback is not set yet
|
|
(let ((pos (point)))
|
|
(setq crdt--buffer-sync-callback
|
|
(lambda ()
|
|
(goto-char
|
|
(max (min pos (point-max))
|
|
(point-min)))))))
|
|
(erase-buffer)
|
|
(crdt--load-ids ids)))
|
|
(crdt--refresh-buffers-maybe)))
|
|
|
|
(define-crdt-message-handler ready (buffer-name mode)
|
|
(crdt--with-buffer-name buffer-name
|
|
(unless (fboundp mode)
|
|
(when (get mode 'crdt-autoload)
|
|
(require (get mode 'crdt-autoload) nil t)))
|
|
(if (fboundp mode)
|
|
(unless (eq major-mode mode)
|
|
(if (not (string-match-p "-mode$" (symbol-name mode))) ; An ad-hoc security check...
|
|
(warn "Remote session uses mode %s, but I refuse to turn it on because it doesn't look like a mode." mode)
|
|
(funcall mode)
|
|
(crdt-mode)))
|
|
(warn "Remote session uses mode %s, but not available locally." mode))
|
|
(unless (crdt--server-p)
|
|
(when (gethash 'crdt-get-write-access (crdt--session-remote-fcap-table crdt--session))
|
|
(read-only-mode -1))
|
|
(when crdt--buffer-sync-callback
|
|
(funcall crdt--buffer-sync-callback)
|
|
(setq crdt--buffer-sync-callback nil)))))
|
|
|
|
(define-crdt-message-handler error (buffer-name &rest err)
|
|
(unless (crdt--server-p)
|
|
(if buffer-name
|
|
(crdt--with-buffer-name buffer-name
|
|
(message "Server side error %s." err)
|
|
(crdt--recover))
|
|
(cl-block nil
|
|
(message "Server side error %s." err)
|
|
(when (eq (car err) 'version)
|
|
(if (version< crdt-protocol-version (cadr err))
|
|
(warn "Server uses newer crdt.el protocol (%s>%s). Please update your crdt.el to connect."
|
|
(cadr err) crdt-protocol-version)
|
|
(warn "Server uses older crdt.el protocol (%s<%s). Please ask to update server."
|
|
(cadr err) crdt-protocol-version)))
|
|
(crdt-disconnect)))))
|
|
|
|
(define-crdt-message-handler add (&rest buffer-names)
|
|
(dolist (buffer-name buffer-names)
|
|
(unless (gethash buffer-name (crdt--session-buffer-table crdt--session))
|
|
(puthash buffer-name nil (crdt--session-buffer-table crdt--session)))
|
|
(crdt--refresh-buffers-maybe)))
|
|
|
|
(define-crdt-message-handler remove (&rest buffer-names)
|
|
(let ((notify-names
|
|
(cl-remove-if-not
|
|
(lambda (buffer-name)
|
|
(gethash buffer-name (crdt--session-buffer-table crdt--session)))
|
|
buffer-names)))
|
|
(when notify-names
|
|
(warn "Server stopped sharing %s."
|
|
(mapconcat #'identity buffer-names ", "))))
|
|
(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 challenge (hash)
|
|
(unless (crdt--server-p) ; server shouldn't receive this
|
|
(message nil)
|
|
(let ((password (read-passwd
|
|
(format "Password for %s:%s: "
|
|
(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-protocol-version
|
|
,(gnutls-hash-mac 'SHA1 password hash)))))))
|
|
|
|
(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 (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."
|
|
(unless (and (process-buffer process)
|
|
(buffer-live-p (process-buffer process)))
|
|
(set-process-buffer process (generate-new-buffer " *crdt-server*"))
|
|
(with-current-buffer (process-buffer process)
|
|
(set-marker (process-mark process) 1)))
|
|
(with-current-buffer (process-buffer process)
|
|
(unless crdt--session
|
|
(setq crdt--session (process-get process 'crdt-session)))
|
|
(when (> (length string) 0)
|
|
(setf (crdt--session-roger-p crdt--session) t))
|
|
(save-excursion
|
|
(goto-char (process-mark process))
|
|
(insert string)
|
|
(set-marker (process-mark process) (point))
|
|
(goto-char (point-min))
|
|
(let (message string start (crdt--process process))
|
|
(while (setq start (point)
|
|
message (ignore-errors (read (current-buffer))))
|
|
(when crdt--log-network-traffic
|
|
(print message))
|
|
(setq string (buffer-substring-no-properties start (point)))
|
|
(delete-region (point-min) (point))
|
|
(goto-char (point-min))
|
|
(condition-case err
|
|
(if (or (not (crdt--server-p)) (process-get process 'authenticated))
|
|
(let ((crdt--inhibit-update t))
|
|
(crdt-process-message message string))
|
|
(cl-block nil
|
|
(when (eq (car message) 'hello)
|
|
(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)))
|
|
(cl-return))
|
|
(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)
|
|
(crdt--greet-client)
|
|
(cl-return))))
|
|
(let ((challenge (crdt--generate-challenge)))
|
|
(process-put process 'challenge
|
|
(gnutls-hash-mac 'SHA1 (substring (process-get process 'password)) challenge))
|
|
(process-send-string process (crdt--format-message `(challenge ,challenge))))))
|
|
((crdt-unrecognized-message invalid-read-syntax)
|
|
(warn "%s error when processing message %s from %s:%s, disconnecting." err message
|
|
(process-contact process :host) (process-contact process :service))
|
|
(if (crdt--server-p)
|
|
(delete-process process)
|
|
(crdt--stop-session crdt--session)))))))))
|
|
|
|
(defun crdt--server-process-sentinel (client _message)
|
|
(let ((crdt--session (process-get client 'crdt-session)))
|
|
(unless (or (process-contact client :server) ; it's actually server itself
|
|
(eq (process-status client) 'open))
|
|
;; client disconnected
|
|
(setf (crdt--session-network-clients crdt--session)
|
|
(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 `(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))
|
|
(maphash
|
|
(lambda (k _)
|
|
(let ((crdt--process client))
|
|
(crdt-process-message-1 `(cursor ,k ,client-id 1 nil 1 nil))))
|
|
(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)
|
|
(let ((session (process-get process 'crdt-session)))
|
|
(when session
|
|
(if (and (not (crdt--session-roger-p session))
|
|
(process-get process 'crdt--downgrade-continuation))
|
|
;; This should only happens when we are in the middle of TLS handshake
|
|
(funcall (process-get process 'crdt--downgrade-continuation))
|
|
(when (process-get process 'tuntox-process)
|
|
(process-send-string
|
|
process
|
|
(crdt--format-message `(leave ,(crdt--session-local-id session)))))
|
|
(crdt--stop-session session))))))
|
|
|
|
;;; UI commands
|
|
|
|
(defvar crdt--ephemeral-advices nil)
|
|
|
|
(defun crdt--call-with-ephemeral-advice (symbol around-advice thunk)
|
|
(let ((wrapped-advice
|
|
(lambda (orig-func &rest args)
|
|
(if (memq symbol crdt--ephemeral-advices)
|
|
(apply around-advice orig-func args)
|
|
(apply orig-func args)))))
|
|
(unwind-protect
|
|
(if (memq symbol crdt--ephemeral-advices)
|
|
(funcall thunk)
|
|
(let ((crdt--ephemeral-advices (cons symbol crdt--ephemeral-advices)))
|
|
(advice-add symbol :around wrapped-advice)
|
|
(funcall thunk)))
|
|
(unless (memq symbol crdt--ephemeral-advices)
|
|
(advice-remove symbol wrapped-advice)))))
|
|
|
|
(defvar crdt-read-settings-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "<tab>") #'forms-next-field)
|
|
(define-key map (kbd "<backtab>") #'forms-prev-field)
|
|
(define-key map "\C-m" #'exit-recursive-edit)
|
|
(define-key map "\C-g" #'abort-recursive-edit)
|
|
(define-key map "\M-n" 'forms-next-record)
|
|
(define-key map "\M-p" 'forms-prev-record)
|
|
(define-key map (kbd "M->") 'forms-first-record)
|
|
(define-key map (kbd "M-<") 'forms-last-record)
|
|
(define-key map [remap forms-insert-record] 'ignore)
|
|
;; (define-key map [remap forms-jump-record] 'ignore)
|
|
(define-key map [remap forms-exit] 'ignore)
|
|
map))
|
|
|
|
(defun crdt-read-settings (buffer-name settings-list)
|
|
"Display a form in a buffer for editing some settings.
|
|
Use the buffer with BUFFER-NAME to display the form (create if
|
|
not exist). Use the buffer with BUFFER-NAME prepended by a space
|
|
to store history (create if not exist).
|
|
SETTINGS-LIST should be a list with elements of the form
|
|
(PROMPT DEFAULT-CONTENT &optional FUNCTION). FUNCTION, if
|
|
non-nil, is called on the user entered string to get the settings
|
|
value. Returns a list of settings values correpsonding to
|
|
SETTINGS-LIST."
|
|
(with-current-buffer (get-buffer-create buffer-name)
|
|
(let ((enable-local-eval t)
|
|
(data-buffer (get-buffer-create (concat " " buffer-name)))
|
|
(default-content-string
|
|
(cl-loop for entry in settings-list
|
|
concat (cadr entry)
|
|
concat "\t")))
|
|
(aset default-content-string (1- (length default-content-string)) ?\n)
|
|
(let ((standard-output (current-buffer)))
|
|
(prin1
|
|
`(setq forms-file t
|
|
forms-number-of-fields ,(length settings-list)
|
|
forms-format-list
|
|
'(,(let ((overriding-local-map crdt-read-settings-map))
|
|
(substitute-command-keys
|
|
crdt-read-settings-help-string))
|
|
,@(cl-loop for i from 1
|
|
for entry in settings-list
|
|
nconc (list (car entry) i "\n"))))))
|
|
(crdt--call-with-ephemeral-advice
|
|
'forms--help 'ignore
|
|
(lambda ()
|
|
(crdt--call-with-ephemeral-advice
|
|
'find-file-noselect
|
|
(lambda (orig-func file)
|
|
(if (eq file t)
|
|
(with-current-buffer data-buffer
|
|
(save-excursion
|
|
(goto-char (point-max))
|
|
(forward-line -1)
|
|
(unless (looking-at-p (regexp-quote default-content-string))
|
|
(goto-char (point-max))
|
|
(insert default-content-string)))
|
|
(current-buffer))
|
|
(funcall orig-func file)))
|
|
#'forms-mode)))
|
|
(unwind-protect
|
|
(progn
|
|
(use-local-map crdt-read-settings-map)
|
|
(display-buffer (current-buffer)
|
|
'(display-buffer-below-selected
|
|
(window-height . fit-window-to-buffer)))
|
|
(select-window (get-buffer-window (current-buffer)))
|
|
(forms-last-record)
|
|
(let ((debug-on-error nil))
|
|
;; avoid reaching start/end of history cause recursive edit to abort
|
|
(recursive-edit))
|
|
(forms--update)
|
|
(cl-mapcar (lambda (entry data)
|
|
(funcall (or (caddr entry) #'identity) data))
|
|
settings-list forms--the-record-list))
|
|
(kill-buffer (current-buffer))
|
|
(unless (< (length (window-list)) 2)
|
|
(delete-window (get-buffer-window (current-buffer))))))))
|
|
|
|
(defun crdt--generate-new-name (name names format)
|
|
"Return a string not in NAMES based on NAME and FORMAT."
|
|
(if (member name names)
|
|
(cl-loop for i from 1
|
|
for new-name = (format format name (number-to-string i))
|
|
unless (member new-name names)
|
|
do (cl-return new-name))
|
|
name))
|
|
|
|
(cl-defun crdt--share-buffer
|
|
(buffer &optional (session crdt--session) (network-name (buffer-name buffer)))
|
|
"Add BUFFER to CRDT SESSION with NETWORK-NAME.
|
|
Possibly add a suffix to NETWORK-NAME to avoid duplicated network names.
|
|
Return BUFFER."
|
|
(cl-flet ((content-message ()
|
|
(save-excursion
|
|
(save-restriction
|
|
(widen)
|
|
(let ((crdt--inhibit-update t))
|
|
(with-silent-modifications
|
|
(crdt--local-insert (point-min) (point-max))))))))
|
|
(let ((new-name (crdt--generate-new-name
|
|
network-name
|
|
(hash-table-keys (crdt--session-buffer-table session))
|
|
"%s<%s>")))
|
|
(if (process-contact (crdt--session-network-process session) :server)
|
|
(with-current-buffer buffer
|
|
(setq crdt--session session)
|
|
(puthash new-name buffer (crdt--session-buffer-table crdt--session))
|
|
(setq crdt--buffer-network-name new-name
|
|
crdt--site-id 0 crdt--site-id-table (make-hash-table))
|
|
(crdt-mode)
|
|
(content-message)
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message `(add ,crdt--buffer-network-name))
|
|
crdt--remote-call-spawn-user-id)
|
|
(crdt--refresh-buffers-maybe)
|
|
(crdt--refresh-sessions-maybe)
|
|
buffer)
|
|
(with-current-buffer buffer
|
|
(setq crdt--buffer-network-name new-name
|
|
crdt--session session)
|
|
(crdt-remote-apply (crdt-get-fcap 'crdt-get-buffer-create) (list new-name))
|
|
|
|
(setq crdt--site-id (crdt-remote-apply (crdt-get-fcap 'crdt-get-write-access) nil))
|
|
(puthash new-name buffer (crdt--session-buffer-table crdt--session))
|
|
(crdt-mode)
|
|
(dolist (message (content-message))
|
|
(crdt--broadcast-maybe (crdt--format-message message)))
|
|
(crdt--broadcast-maybe (crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode))))))))
|
|
|
|
(defun crdt--settings-make-ensure-type (type-predicate)
|
|
(lambda (string)
|
|
(let ((result (car (read-from-string string))))
|
|
(unless (funcall type-predicate result)
|
|
(signal 'wrong-type-argument (list type-predicate result)))
|
|
result)))
|
|
|
|
(defun crdt--settings-make-ensure-nonempty (default)
|
|
(lambda (string)
|
|
(if (and string (> (length string) 0))
|
|
string default)))
|
|
|
|
;;;###autoload
|
|
(defun crdt-share-buffer (session-name)
|
|
"Share the current buffer in the CRDT session with name SESSION-NAME.
|
|
Create a new one if such a CRDT session doesn't exist."
|
|
(interactive
|
|
(progn
|
|
(when (and crdt-mode crdt--session)
|
|
(error "Current buffer is already shared in a CRDT session"))
|
|
(list (let* ((session-names (mapcar #'crdt--session-urlstr crdt--session-list))
|
|
(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
|
|
(current-buffer)
|
|
(or session
|
|
(apply #'crdt-new-session
|
|
(crdt-read-settings
|
|
(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)))
|
|
("Password: " "")
|
|
("Display Name: " ,crdt-default-name)
|
|
("Command Functions: "
|
|
,(prin1-to-string crdt-default-session-permissions)
|
|
,(crdt--settings-make-ensure-type 'listp)))))))))
|
|
|
|
(cl-defun crdt-stop-share-buffer (&optional (session crdt--session)
|
|
(network-name crdt--buffer-network-name))
|
|
"Stop sharing buffer with NETWORK-NAME in SESSION."
|
|
(interactive (let ((session (crdt--read-session-maybe 'server)))
|
|
(list session (crdt--read-buffer-maybe session))))
|
|
(if 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."))
|
|
(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 `(,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"
|
|
(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 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.
|
|
PERMISSIONS is a list that describes policies
|
|
for public session-scoped functionss.
|
|
Each element should be one of
|
|
- a function, which should return a list of `crdt-local-fcap's when
|
|
called with a single argument USER-ID.
|
|
The returned list of fcaps is made accessible
|
|
to the user with USER-ID in every buffer.
|
|
- a symbol, which has a list of `crdt-local-fcap's as its value.
|
|
These fcaps are made accessible to every user, in every buffer.
|
|
- a list of `crdt-local-fcap's
|
|
These fcaps are made accessible to every user, in every buffer."
|
|
(let* ((network-process (make-network-process
|
|
:name "CRDT Server"
|
|
:server t
|
|
:host "0.0.0.0"
|
|
:service port
|
|
:filter #'crdt--network-filter
|
|
:filter-multibyte nil
|
|
:sentinel #'crdt--server-process-sentinel
|
|
:coding 'utf-8))
|
|
(new-session
|
|
(crdt--make-session :local-id 0
|
|
:local-clock 0
|
|
:next-user-id 1
|
|
:local-name display-name
|
|
:host "localhost" :service port
|
|
:urlstr (format "localhost:%s" port)
|
|
:network-process network-process
|
|
:permissions permissions))
|
|
(tuntox-p (or (eq crdt-use-tuntox t)
|
|
(and (eq crdt-use-tuntox 'confirm)
|
|
(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 ; TODO: factor this out like `crdt-start-stunnel'
|
|
(let* ((password-p (and password (> (length password) 0)))
|
|
(proxy-process
|
|
(make-process :name "Tuntox Proxy"
|
|
:buffer (generate-new-buffer "*Tuntox Proxy*")
|
|
:command
|
|
`(,crdt-tuntox-executable
|
|
"-C" ,(expand-file-name crdt-tuntox-key-path)
|
|
"-f" "/dev/stdin" ; do the filtering for safety sake
|
|
,@ (when password-p
|
|
`("-s" ,password)))
|
|
:filter
|
|
(lambda (proc string)
|
|
(cond
|
|
((string-match "An UDP connection has been established" string) (message "Connected to Tuntox network."))
|
|
((string-match "Lost connection to server" string) (warn "Lost connection to Tuntox network!")))
|
|
(when (buffer-live-p (process-buffer proc))
|
|
(with-current-buffer (process-buffer proc)
|
|
(let ((moving (= (point) (process-mark proc))))
|
|
(save-excursion
|
|
(goto-char (process-mark proc))
|
|
(insert string)
|
|
(set-marker (process-mark proc) (point)))
|
|
(if moving (goto-char (process-mark proc))))))))))
|
|
(message "Connecting to Tuntox network...")
|
|
(when password-p
|
|
(process-put proxy-process 'password password))
|
|
(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))
|
|
(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)
|
|
"Kill the CRDT SESSION."
|
|
(interactive (list (crdt--read-session-maybe 'server)))
|
|
(when (if (and crdt-confirm-disconnect
|
|
(crdt--server-p session)
|
|
(crdt--session-network-clients session))
|
|
(yes-or-no-p "There are yet connected clients. Stop session? ")
|
|
t)
|
|
(dolist (client (crdt--session-network-clients session))
|
|
(when (process-live-p client)
|
|
(delete-process client))
|
|
(when (process-buffer client)
|
|
(kill-buffer (process-buffer client))))
|
|
(when (crdt--session-user-menu-buffer session)
|
|
(kill-buffer (crdt--session-user-menu-buffer session)))
|
|
(when (crdt--session-buffer-menu-buffer session)
|
|
(kill-buffer (crdt--session-buffer-menu-buffer session)))
|
|
(maphash
|
|
(lambda (_ v)
|
|
(when (and v (buffer-live-p v))
|
|
(with-current-buffer v
|
|
(setq crdt--session nil)
|
|
(crdt-mode 0))))
|
|
(crdt--session-buffer-table session))
|
|
(setq crdt--session-list
|
|
(delq session crdt--session-list))
|
|
(crdt--refresh-sessions-maybe)
|
|
(let* ((process (crdt--session-network-process session))
|
|
(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))
|
|
(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-urlstr session)))))
|
|
|
|
(defun crdt-stop-session (&optional session)
|
|
"Stop sharing the SESSION.
|
|
If SESSION is nil, stop sharing the current session."
|
|
(interactive
|
|
(list (crdt--read-session-maybe 'server)))
|
|
(crdt--stop-session (or session crdt--session)))
|
|
|
|
(defun crdt-copy-url (&optional session)
|
|
"Copy the url for the SESSION.
|
|
Currently this only work if a tuntox proxy is used."
|
|
(interactive
|
|
(list (crdt--read-session-maybe 'server)))
|
|
(let* ((session (or session crdt--session))
|
|
(network-process (crdt--session-network-process session))
|
|
(tuntox-process (process-get network-process 'tuntox-process)))
|
|
(if tuntox-process
|
|
(let ((url-base (format "tuntox://%s:%s"
|
|
(with-current-buffer (process-buffer tuntox-process)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(search-forward "Using Tox ID: ")
|
|
(let ((start (point)))
|
|
(end-of-line)
|
|
(buffer-substring-no-properties start (point)))))
|
|
(process-contact network-process :service))))
|
|
(kill-new (if (and crdt-tuntox-password-in-url (process-get tuntox-process 'password))
|
|
(format "%s?pwd=%s"
|
|
url-base
|
|
(process-get tuntox-process 'password))
|
|
url-base))
|
|
(message "URL copied."))
|
|
(message "No known URL to copy, find out your public IP address yourself!"))))
|
|
|
|
(defun crdt-disconnect (&optional session)
|
|
"Disconnect from client SESSION.
|
|
If SESSION is nil, disconnect from the current session."
|
|
(interactive
|
|
(list (crdt--read-session-maybe 'client)))
|
|
(crdt--stop-session (or session crdt--session)))
|
|
|
|
(defvar crdt-connect-url-history nil)
|
|
|
|
;;;###autoload
|
|
(defun crdt-connect (url display-name)
|
|
"Connect to a CRDT server running at URL.
|
|
Open a new buffer to display the shared content.
|
|
Join with DISPLAY-NAME."
|
|
(interactive
|
|
(crdt-read-settings
|
|
"*CRDT Connect Settings*"
|
|
`(("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
|
|
(let ((inferred-protocol
|
|
(cond ((eq (url-portspec parsed-url) 6530) "ein")
|
|
((eq (url-portspec parsed-url) 6540) "eins")
|
|
(crdt-default-tls "eins")
|
|
(t "ein"))))
|
|
(setq parsed-url (url-generic-parse-url (concat inferred-protocol "://" 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)))))
|
|
(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))
|
|
(new-session (crdt--make-session :local-clock 0 :local-name display-name)))
|
|
(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
|
|
:filter-multibyte nil
|
|
:sentinel #'crdt--client-process-sentinel
|
|
:coding 'utf-8
|
|
process-args)))
|
|
(setf (crdt--session-urlstr new-session) (url-recreate-url url)
|
|
(crdt--session-network-process new-session) network-process)
|
|
(process-put network-process 'crdt-session new-session)
|
|
(process-send-string
|
|
network-process
|
|
(crdt--format-message
|
|
`(hello ,crdt-protocol-version)))
|
|
network-process)))
|
|
(cond ((equal url-type "ein")
|
|
(start-session :host (url-host url) :service (url-portspec url)))
|
|
((equal url-type "eins")
|
|
(cl-flet ((downgrade ()
|
|
(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)))))
|
|
(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))))))
|
|
(when (= (url-portspec url) 6540)
|
|
(process-put proc 'crdt--downgrade-continuation
|
|
(lambda ()
|
|
(process-put proc 'crdt--downgrade-continuation nil)
|
|
(downgrade))))
|
|
proc)
|
|
(file-error
|
|
(if (= (url-portspec url) 6540)
|
|
(downgrade)
|
|
(signal (car c) (cdr c)))))))
|
|
((equal url-type "tuntox")
|
|
(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 (or (when (url-filename url)
|
|
(cadr (split-string (url-filename url) "?pwd=")))
|
|
(read-passwd "tuntox password (empty for no password): "))))
|
|
(message "Connecting to Tuntox network...")
|
|
(make-process
|
|
:name "Tuntox Proxy"
|
|
:buffer (generate-new-buffer "*Tuntox Proxy*")
|
|
:command
|
|
`(,crdt-tuntox-executable
|
|
"-i" ,(url-host url)
|
|
"-L" ,(format "%s:127.0.0.1:%s" port (url-portspec url))
|
|
,@ (when (> (length password) 0)
|
|
`("-s" ,password)))
|
|
:filter
|
|
(let (initialized)
|
|
(lambda (proc string)
|
|
(cond
|
|
((string-match "An UDP connection has been established" string) (message "Connected to Tuntox network, finding host..."))
|
|
((string-match "Lost connection to server" string) (warn "Lost connection to Tuntox network!")))
|
|
(when (buffer-live-p (process-buffer proc))
|
|
(with-current-buffer (process-buffer proc)
|
|
(let ((moving (= (point) (process-mark proc))))
|
|
(save-excursion
|
|
(goto-char (process-mark proc))
|
|
(insert string)
|
|
(set-marker (process-mark proc) (point))
|
|
(unless initialized
|
|
(when (ignore-errors (search-backward "Friend request accepted"))
|
|
(setq initialized t)
|
|
(message "Connected to host over Tuntox.")
|
|
(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)))
|
|
(push new-session crdt--session-list)
|
|
(let ((crdt--session new-session))
|
|
(crdt-list-buffers))
|
|
new-session)))
|
|
|
|
;;; overlay tracking
|
|
|
|
(defvar crdt--inhibit-overlay-advices nil)
|
|
|
|
(defvar crdt--modifying-overlay-metadata nil)
|
|
|
|
(defun crdt--enable-overlay-species (species)
|
|
(push species crdt--enabled-overlay-species)
|
|
(when crdt-mode
|
|
(let ((crdt--inhibit-overlay-advices t))
|
|
(maphash (lambda (_ ov)
|
|
(let ((meta (overlay-get ov 'crdt-meta)))
|
|
(when (eq species (crdt--overlay-metadata-species meta))
|
|
(cl-loop for (prop value) on (crdt--overlay-metadata-plist meta) by #'cddr
|
|
do (overlay-put ov prop value)))))
|
|
crdt--overlay-table))))
|
|
|
|
(defun crdt--disable-overlay-species (species)
|
|
(setq crdt--enabled-overlay-species (delq species crdt--enabled-overlay-species))
|
|
(when crdt-mode
|
|
(let ((crdt--inhibit-overlay-advices t))
|
|
(maphash (lambda (_ ov)
|
|
(let ((meta (overlay-get ov 'crdt-meta)))
|
|
(when (eq species (crdt--overlay-metadata-species meta))
|
|
(cl-loop for (prop _value) on (crdt--overlay-metadata-plist meta) by #'cddr
|
|
do (overlay-put ov prop nil)))))
|
|
crdt--overlay-table))))
|
|
|
|
(defun crdt--make-overlay-advice (orig-fun beg end &optional buffer front-advance rear-advance)
|
|
(let ((new-overlay (funcall orig-fun beg end buffer front-advance rear-advance)))
|
|
;; should we check if we are in the current buffer?
|
|
(when crdt-mode
|
|
(when crdt--track-overlay-species
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message
|
|
(crdt--overlay-add-message (crdt--session-local-id crdt--session)
|
|
(crdt--session-local-clock crdt--session)
|
|
crdt--track-overlay-species front-advance rear-advance
|
|
beg end)))
|
|
(let* ((key (cons (crdt--session-local-id crdt--session)
|
|
(crdt--session-local-clock crdt--session)))
|
|
(meta (crdt--make-overlay-metadata key crdt--track-overlay-species
|
|
front-advance rear-advance nil)))
|
|
(puthash key new-overlay crdt--overlay-table)
|
|
(let ((crdt--inhibit-overlay-advices t)
|
|
(crdt--modifying-overlay-metadata t))
|
|
(overlay-put new-overlay 'crdt-meta meta)))
|
|
(cl-incf (crdt--session-local-clock crdt--session))))
|
|
new-overlay))
|
|
|
|
(define-crdt-message-handler overlay-add
|
|
(buffer-name user-id logical-clock species
|
|
front-advance rear-advance start-hint start-id end-hint end-id)
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(let* ((crdt--track-overlay-species nil)
|
|
(start (crdt--find-id start-id start-hint front-advance))
|
|
(end (crdt--find-id end-id end-hint rear-advance))
|
|
(new-overlay
|
|
(make-overlay start end nil front-advance rear-advance))
|
|
(key (cons user-id logical-clock))
|
|
(meta (crdt--make-overlay-metadata key species
|
|
front-advance rear-advance nil)))
|
|
(puthash key new-overlay crdt--overlay-table)
|
|
(let ((crdt--inhibit-overlay-advices t)
|
|
(crdt--modifying-overlay-metadata t))
|
|
(overlay-put new-overlay 'crdt-meta meta)))))
|
|
(crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
|
|
|
|
(defun crdt--move-overlay-advice (orig-fun ov beg end &rest args)
|
|
(when crdt-mode
|
|
(unless crdt--inhibit-overlay-advices
|
|
(let ((meta (overlay-get ov 'crdt-meta)))
|
|
(when meta ;; to be fixed
|
|
(let ((key (crdt--overlay-metadata-lamport-timestamp meta))
|
|
(front-advance (crdt--overlay-metadata-front-advance meta))
|
|
(rear-advance (crdt--overlay-metadata-rear-advance meta)))
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message
|
|
`(overlay-move ,crdt--buffer-network-name ,(car key) ,(cdr key)
|
|
,beg ,(if front-advance
|
|
(crdt--get-id beg)
|
|
(crdt--get-id (1- beg)))
|
|
,end ,(if rear-advance
|
|
(crdt--get-id end)
|
|
(crdt--get-id (1- end)))))))))))
|
|
(apply orig-fun ov beg end args))
|
|
|
|
(define-crdt-message-handler overlay-move
|
|
(buffer-name user-id logical-clock
|
|
start-hint start-id end-hint end-id)
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(let* ((key (cons user-id logical-clock))
|
|
(ov (gethash key crdt--overlay-table)))
|
|
(when ov
|
|
(let* ((meta (overlay-get ov 'crdt-meta))
|
|
(front-advance (crdt--overlay-metadata-front-advance meta))
|
|
(rear-advance (crdt--overlay-metadata-rear-advance meta))
|
|
(start (crdt--find-id start-id start-hint front-advance))
|
|
(end (crdt--find-id end-id end-hint rear-advance)))
|
|
(let ((crdt--inhibit-overlay-advices t))
|
|
(move-overlay ov start end)))))))
|
|
(crdt--broadcast-maybe crdt--message-string nil))
|
|
|
|
(defun crdt--delete-overlay-advice (orig-fun ov)
|
|
(unless crdt--inhibit-overlay-advices
|
|
(when crdt-mode
|
|
(let ((meta (overlay-get ov 'crdt-meta)))
|
|
(when meta
|
|
(let ((key (crdt--overlay-metadata-lamport-timestamp meta)))
|
|
(remhash key crdt--overlay-table)
|
|
(crdt--broadcast-maybe (crdt--format-message
|
|
`(overlay-remove ,crdt--buffer-network-name ,(car key) ,(cdr key)))))))))
|
|
(funcall orig-fun ov))
|
|
|
|
(define-crdt-message-handler overlay-remove (buffer-name user-id logical-clock)
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(let* ((key (cons user-id logical-clock))
|
|
(ov (gethash key crdt--overlay-table)))
|
|
(when ov
|
|
(remhash key crdt--overlay-table)
|
|
(let ((crdt--inhibit-overlay-advices t))
|
|
(delete-overlay ov))))))
|
|
(crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
|
|
|
|
(defun crdt--overlay-put-advice (orig-fun ov prop value)
|
|
(unless (and (eq prop 'crdt-meta)
|
|
(not crdt--modifying-overlay-metadata))
|
|
(when crdt-mode
|
|
(unless crdt--inhibit-overlay-advices
|
|
(let ((meta (overlay-get ov 'crdt-meta)))
|
|
(when meta
|
|
(setf (crdt--overlay-metadata-plist meta)
|
|
(plist-put (crdt--overlay-metadata-plist meta) prop value))
|
|
(let* ((key (crdt--overlay-metadata-lamport-timestamp meta))
|
|
(message (crdt--format-message
|
|
`(overlay-put ,crdt--buffer-network-name
|
|
,(car key) ,(cdr key) ,prop ,(crdt--readable-encode value)))))
|
|
(crdt--broadcast-maybe message))))))
|
|
(funcall orig-fun ov prop value)))
|
|
|
|
(define-crdt-message-handler overlay-put (buffer-name user-id logical-clock prop value)
|
|
(setq value (crdt--readable-decode value))
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(let ((ov (gethash (cons user-id logical-clock) crdt--overlay-table)))
|
|
(when ov
|
|
(let ((meta (overlay-get ov 'crdt-meta)))
|
|
(setf (crdt--overlay-metadata-plist meta)
|
|
(plist-put (crdt--overlay-metadata-plist meta) prop value))
|
|
(when (memq (crdt--overlay-metadata-species meta) crdt--enabled-overlay-species)
|
|
(let ((crdt--inhibit-overlay-advices t))
|
|
(overlay-put ov prop value))))))))
|
|
(crdt--broadcast-maybe crdt--message-string nil))
|
|
|
|
(advice-add 'make-overlay :around #'crdt--make-overlay-advice)
|
|
(advice-add 'move-overlay :around #'crdt--move-overlay-advice)
|
|
(advice-add 'delete-overlay :around #'crdt--delete-overlay-advice)
|
|
(advice-add 'overlay-put :around #'crdt--overlay-put-advice)
|
|
|
|
;;; Auxillary autoload
|
|
|
|
(defun crdt-register-autoload (mode feature)
|
|
"Register for autoloading FEATURE before CRDT enforce major MODE."
|
|
(put mode 'crdt-autoload feature))
|
|
|
|
;;; Remote Function
|
|
|
|
(cl-defun crdt--assemble-state-list (states &optional (session crdt--session))
|
|
(let (result)
|
|
(cl-labels ((collect (entry tail)
|
|
(unless (assq entry result) (push (cons entry tail) result)))
|
|
(process (entry)
|
|
(cl-ecase entry
|
|
((region) (mapc #'process '(point mark mark-active transient-mark-mode)))
|
|
((buffer)
|
|
(unless (and crdt--session crdt--buffer-network-name) ;; TODO: capability safe
|
|
(crdt--share-buffer (current-buffer) session))
|
|
(collect entry (list crdt--buffer-network-name)))
|
|
((window)
|
|
(with-current-buffer (window-buffer (selected-window))
|
|
(unless (and crdt--session crdt--buffer-network-name) ;; TODO: capability safe
|
|
(crdt--share-buffer (current-buffer) session))
|
|
(collect entry (list crdt--buffer-network-name
|
|
(window-point (selected-window))))))
|
|
((point) (process 'buffer)
|
|
(collect entry (list (crdt--get-id (point)) (point))))
|
|
((mark) (process 'buffer)
|
|
(collect entry (list (crdt--get-id (mark)) (mark))))
|
|
((mark-active transient-mark-mode last-command-event)
|
|
(collect entry (list (crdt--readable-encode (symbol-value entry))) result)))))
|
|
(mapc #'process states))
|
|
(nreverse result)))
|
|
|
|
(defun crdt--apply-state-list (state-list)
|
|
(let (vars vals)
|
|
(cl-loop for entry in state-list
|
|
for rest on state-list
|
|
do (cl-case (car entry)
|
|
((buffer)
|
|
(set-buffer
|
|
(crdt--with-buffer-name-pull ((cadr entry) :sync t)
|
|
(current-buffer))))
|
|
((window)
|
|
(switch-to-buffer
|
|
(crdt--with-buffer-name-pull ((cadr entry) :sync t)
|
|
(current-buffer)))
|
|
(set-window-point (selected-window) (caddr entry)))
|
|
((point) (goto-char (apply #'crdt--id-to-pos (cdr entry))))
|
|
((mark) (set-mark (apply #'crdt--id-to-pos (cdr entry))))
|
|
((mark-active transient-mark-mode last-command-event)
|
|
(push (car entry) vars)
|
|
(push (crdt--readable-decode (cadr entry)) vals))))
|
|
(cons vars vals)))
|
|
|
|
(defun crdt-toggle-override-command ()
|
|
"Toggle whether to override local commands with remote commands."
|
|
(interactive)
|
|
(if crdt-override-command
|
|
(progn
|
|
(setq crdt-override-command nil)
|
|
(dolist (session crdt--session-list)
|
|
(maphash (lambda (fcap-symbol _)
|
|
(advice-remove fcap-symbol 'crdt-remote-fcap))
|
|
(crdt--session-remote-fcap-table session))))
|
|
(setq crdt-override-command t)
|
|
(dolist (session crdt--session-list)
|
|
(maphash (lambda (fcap-symbol _)
|
|
(advice-add fcap-symbol :around (crdt--make-remote-command-advice fcap-symbol)
|
|
'((name . crdt-remote-fcap))))
|
|
(crdt--session-remote-fcap-table session))))
|
|
(message "Overriding remote command %s"
|
|
(if crdt-override-command "enabled" "disabled")))
|
|
|
|
(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--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)))
|
|
(when buffer
|
|
(with-current-buffer buffer (read-only-mode -1)))))))
|
|
|
|
(define-crdt-message-handler funcall
|
|
(user-id logical-clock spawn-user-id
|
|
state-list nonce fcap-symbol &rest args)
|
|
(let* ((crdt--inhibit-update nil)
|
|
(crdt--remote-call-spawn-user-id spawn-user-id)
|
|
(saved-session crdt--session)
|
|
(return-message
|
|
(condition-case err
|
|
(let ((fcap (gethash fcap-symbol (crdt--session-local-fcap-table crdt--session))))
|
|
(if fcap
|
|
(if (string-equal nonce (crdt-local-fcap-nonce fcap))
|
|
(save-mark-and-excursion
|
|
(save-window-excursion
|
|
(let ((bindings (crdt--apply-state-list state-list)))
|
|
(cl-progv (car bindings) (cdr bindings)
|
|
(prog1 (list t (apply (crdt-local-fcap-proxy fcap) (mapcar #'crdt--readable-decode args)))
|
|
(setq state-list (crdt--assemble-state-list (crdt-local-fcap-out-states fcap) saved-session)))))))
|
|
(list nil 'crdt-invalid-fcap fcap-symbol))
|
|
(list nil 'crdt-invalid-fcap fcap-symbol)))
|
|
(error (list nil (car err) (crdt--readable-encode (cdr err))))))
|
|
(msg (crdt--format-message
|
|
`(return ,user-id ,logical-clock
|
|
,state-list ,@(crdt--readable-encode return-message)))))
|
|
(crdt--log-send-network-traffic msg)
|
|
(process-send-string crdt--process msg)))
|
|
|
|
(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))
|
|
crdt--return-message-table)))
|
|
|
|
(cl-defun crdt-remote-apply
|
|
(remote-fcap args &optional (spawn-user-id (crdt--session-local-id crdt--session)))
|
|
"Remote call REMOTE-FCAP with ARGS.
|
|
SPAWN-USER-ID is the user ID where the series of remote calls
|
|
originally started."
|
|
(let* ((user-id (crdt--session-local-id crdt--session))
|
|
(logical-clock (crdt--session-local-clock crdt--session))
|
|
(msg (crdt--format-message
|
|
`(funcall ,user-id
|
|
,logical-clock ,spawn-user-id
|
|
,(crdt--assemble-state-list (crdt-remote-fcap-in-states remote-fcap))
|
|
,(crdt-remote-fcap-nonce remote-fcap)
|
|
,(crdt-remote-fcap-name remote-fcap)
|
|
,@(mapcar #'crdt--readable-encode args)))))
|
|
(crdt--log-send-network-traffic msg)
|
|
(process-send-string (crdt--session-network-process crdt--session) msg)
|
|
(cl-incf (crdt--session-local-clock crdt--session))
|
|
(while (not (gethash logical-clock crdt--return-message-table))
|
|
(accept-process-output (crdt--session-network-process crdt--session)))
|
|
(let ((return-message (gethash logical-clock crdt--return-message-table)))
|
|
(remhash logical-clock crdt--return-message-table)
|
|
(cl-destructuring-bind (state-list success-p &rest return-values) return-message
|
|
(crdt--apply-state-list state-list)
|
|
(if success-p
|
|
(car return-values)
|
|
(signal (car return-values) (cdr return-values)))))))
|
|
|
|
(defun crdt-remote-call-interactively (remote-fcap spawn-user-id)
|
|
"Remote call REMOTE-FCAP interactively.
|
|
SPAWN-USER-ID is the site where the series of remote calls originally started."
|
|
(crdt-remote-apply remote-fcap
|
|
(advice-eval-interactive-spec (crdt-remote-fcap-interactive-form remote-fcap))
|
|
spawn-user-id))
|
|
|
|
(defun crdt-M-x ()
|
|
(interactive)
|
|
(unless crdt--session
|
|
(error "Not a CRDT shared buffer"))
|
|
(let* ((table (crdt--session-remote-fcap-table crdt--session))
|
|
(command-symbol
|
|
(intern-soft
|
|
(completing-read "CRDT Remote Command: "
|
|
(hash-table-keys table)
|
|
(lambda (key) (crdt-remote-fcap-interactive-form (gethash key table)))
|
|
t))))
|
|
(crdt-remote-call-interactively (crdt-get-fcap command-symbol) (crdt--session-local-id crdt--session))))
|
|
|
|
(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
|
|
|
|
(defvar-local crdt-variables nil)
|
|
|
|
(cl-defun crdt--send-variables-maybe (&optional (incremental t))
|
|
(dolist (var crdt-variables)
|
|
(let ((sender (car (get var 'crdt-variable-scheme))))
|
|
(let ((msg (funcall sender var incremental)))
|
|
(unless (eq msg 'crdt-unchanged)
|
|
(crdt--broadcast-maybe (crdt--format-message
|
|
`(var ,crdt--buffer-network-name ,var ,@(crdt--readable-encode msg)))))))))
|
|
|
|
(define-crdt-message-handler var (buffer-name variable-symbol . args)
|
|
(crdt--with-buffer-name buffer-name
|
|
(funcall (cdr (get variable-symbol 'crdt-variable-scheme))
|
|
variable-symbol args)))
|
|
|
|
;; Tree diff
|
|
;; We use it to provide an incremental variable sender/receiver for general Lisp data structure.
|
|
;; Currently we use a naive algorithm which should work reasonably well
|
|
;; when there are few shape changes.
|
|
;; The naive algorithm also runs in linear time and space.
|
|
;; Sophiscated algorithms that computes minimal editing distance are usually much more expensive.
|
|
|
|
(defsubst crdt--exhaust-thunk (thunk)
|
|
"Keep forcing THUNK until it no longer returns a function.
|
|
For poor man's TCO."
|
|
(while (functionp thunk)
|
|
(setq thunk (funcall thunk))))
|
|
|
|
(defun crdt--diff (old new)
|
|
"Compute tree diff between OLD and NEW.
|
|
The result DIFF can be used in (CRDT--NAPPLY-DIFF OLD DIFF) to reproduce NEW."
|
|
(let (result)
|
|
(cl-labels
|
|
;; we could do a running length encoding of path
|
|
;; not bothering that for now
|
|
((process (path old new vindex)
|
|
(cl-typecase old
|
|
(cons (if (consp new)
|
|
(progn
|
|
(crdt--exhaust-thunk
|
|
(process (concat path "a") (car old) (car new) 0))
|
|
(lambda () (process (concat path "d") (cdr old) (cdr new) 0)))
|
|
(push (list path new) result)))
|
|
(vector (cond ((not (vectorp new)) (push (list path new) result))
|
|
((>= vindex (length old))
|
|
(unless (= (length old) (length new))
|
|
(push (list path (substring new vindex)) result)))
|
|
((>= vindex (length new))
|
|
(push (list path nil) result))
|
|
(t
|
|
(crdt--exhaust-thunk
|
|
(process (concat path "a") (aref old vindex) (aref new vindex) 0))
|
|
(lambda () (process (concat path "d") old new (1+ vindex))))))
|
|
(t (unless (eql old new) (push (list path new) result))))))
|
|
(crdt--exhaust-thunk (process nil old new 0))
|
|
result)))
|
|
|
|
(defun crdt--napply-diff (old diff)
|
|
"Destructively apply DIFF produced by CRDT--DIFF to OLD."
|
|
;; we could do them in one pass
|
|
;; not bothering that for now
|
|
(dolist (update diff)
|
|
(cl-destructuring-bind (path new) update
|
|
(let ((cursor
|
|
(lambda (msg &optional data)
|
|
(cl-ecase msg
|
|
((get) old)
|
|
((set) (setq old data))
|
|
((vindex) 0)))))
|
|
(dotimes (path-index (length path))
|
|
(let ((cursor-data (funcall cursor 'get)))
|
|
(cl-ecase (aref path path-index)
|
|
((?a)
|
|
(cl-etypecase cursor-data
|
|
(cons (setq cursor
|
|
(lambda (msg &optional data)
|
|
(cl-ecase msg
|
|
((get) (car cursor-data))
|
|
((set) (rplaca cursor-data data))
|
|
((vindex) 0)))))
|
|
(vector (setq cursor
|
|
(let ((vindex (funcall cursor 'vindex)))
|
|
(lambda (msg &optional data)
|
|
(cl-ecase msg
|
|
((get) (aref cursor-data vindex))
|
|
((set) (aset cursor-data vindex data))
|
|
((vindex) 0))))))))
|
|
((?d)
|
|
(cl-etypecase cursor-data
|
|
(cons
|
|
(setq cursor
|
|
(lambda (msg &optional data)
|
|
(cl-ecase msg
|
|
((get) (cdr cursor-data))
|
|
((set) (rplacd cursor-data data))
|
|
((vindex) 0)))))
|
|
(vector (setq cursor
|
|
(let ((saved-cursor cursor)
|
|
(vindex (1+ (funcall cursor 'vindex))))
|
|
(lambda (msg &optional data)
|
|
(cl-ecase msg
|
|
((get) cursor-data)
|
|
((set)
|
|
(lambda ()
|
|
(funcall saved-cursor 'set
|
|
(if data
|
|
(vconcat cursor-data data)
|
|
(substring cursor-data 0 vindex)))))
|
|
((vindex) vindex)))))))))))
|
|
(crdt--exhaust-thunk (funcall cursor 'set new)))))
|
|
old)
|
|
|
|
(defun crdt--diff-server-variable-sender (var incremental)
|
|
(if (crdt--server-p)
|
|
(if incremental
|
|
(let ((diff (crdt--diff (get var 'crdt--diff-cache) (symbol-value var))))
|
|
(if diff
|
|
(progn (put var 'crdt--diff-cache (copy-tree (symbol-value var) t))
|
|
diff)
|
|
'crdt-unchanged))
|
|
(list (list "" (symbol-value var))))
|
|
'crdt-unchanged))
|
|
|
|
(defun crdt--diff-server-variable-receiver (var args)
|
|
(unless (crdt--server-p)
|
|
(set var (crdt--napply-diff (symbol-value var) args))))
|
|
|
|
(defvar crdt-variable-scheme-diff-server (cons #'crdt--diff-server-variable-sender #'crdt--diff-server-variable-receiver))
|
|
|
|
(defun crdt-register-variable (variable scheme)
|
|
(add-to-list 'crdt-variables variable)
|
|
(put variable 'crdt-variable-scheme
|
|
(if (symbolp scheme) (symbol-value scheme) scheme)))
|
|
|
|
(defun crdt-unregister-variable (variable)
|
|
(delq variable crdt-variables))
|
|
|
|
(defun crdt-register-variables (variable-entries)
|
|
(dolist (entry variable-entries)
|
|
(apply #'crdt-register-variable entry)))
|
|
|
|
(defun crdt-unregister-variables (variable-entries)
|
|
(dolist (entry variable-entries)
|
|
(crdt-unregister-variable (car entry))))
|
|
|
|
;;; pseudo process
|
|
|
|
(cl-defstruct (crdt--pseudo-process (:constructor crdt--make-pseudo-process))
|
|
buffer mark)
|
|
|
|
(defun crdt--pseudo-process-send-string (pseudo-process string)
|
|
(with-current-buffer (crdt--pseudo-process-buffer pseudo-process)
|
|
(crdt--broadcast-maybe (crdt--format-message
|
|
`(process ,crdt--buffer-network-name ,string)))))
|
|
|
|
(defun crdt--process-send-string-advice (orig-func process string)
|
|
(if (crdt--pseudo-process-p process)
|
|
(crdt--pseudo-process-send-string process string)
|
|
(funcall orig-func process string)))
|
|
|
|
(defun crdt--process-send-region-advice (orig-func process start end)
|
|
(if (crdt--pseudo-process-p process)
|
|
(crdt--pseudo-process-send-string process (buffer-substring-no-properties start end))
|
|
(funcall orig-func process start end)))
|
|
|
|
(defun crdt--get-buffer-process-advice (orig-func buffer)
|
|
(or (funcall orig-func buffer)
|
|
(and buffer
|
|
(setq buffer (get-buffer buffer))
|
|
(buffer-live-p buffer)
|
|
(with-current-buffer buffer
|
|
(or (funcall orig-func buffer)
|
|
(and crdt--session (not (crdt--server-p))
|
|
crdt--buffer-pseudo-process))))))
|
|
|
|
(defun crdt--get-process-advice (orig-func name)
|
|
(if (crdt--pseudo-process-p name)
|
|
name
|
|
(funcall orig-func name)))
|
|
|
|
(defun crdt--process-mark-advice (orig-func process)
|
|
(if (crdt--pseudo-process-p process)
|
|
(crdt--pseudo-process-mark process)
|
|
(funcall orig-func process)))
|
|
|
|
(defun crdt--process-name-advice (orig-func process)
|
|
(if (crdt--pseudo-process-p process)
|
|
process
|
|
(funcall orig-func process)))
|
|
|
|
(define-crdt-message-handler process-mark (buffer-name crdt-id position-hint)
|
|
(crdt--with-buffer-name buffer-name
|
|
(crdt--with-recover
|
|
(save-excursion
|
|
(goto-char (crdt--id-to-pos crdt-id position-hint))
|
|
(let ((buffer-process (get-buffer-process (current-buffer))))
|
|
(if buffer-process
|
|
(progn (set-marker (process-mark buffer-process) (point))
|
|
(setq crdt--last-process-mark-id crdt-id)
|
|
(crdt--broadcast-maybe crdt--message-string (crdt--client-id)))
|
|
(unless (crdt--server-p)
|
|
(setq crdt--buffer-pseudo-process
|
|
(crdt--make-pseudo-process :buffer (current-buffer) :mark (point-marker)))
|
|
(setq crdt--last-process-mark-id crdt-id))))))))
|
|
|
|
(cl-defun crdt--send-process-mark-maybe (&optional (lazy t))
|
|
(let ((buffer-process (get-buffer-process (current-buffer))))
|
|
(when buffer-process
|
|
(let* ((mark (process-mark buffer-process)))
|
|
(when mark
|
|
(let* ((mark-pos (marker-position mark)))
|
|
(when mark-pos
|
|
(let* ((current-id (crdt--get-id mark-pos)))
|
|
(unless (and lazy (string-equal crdt--last-process-mark-id current-id))
|
|
(setq crdt--last-process-mark-id current-id)
|
|
(crdt--broadcast-maybe
|
|
(crdt--format-message
|
|
`(process-mark ,crdt--buffer-network-name
|
|
,current-id ,mark-pos))))))))))))
|
|
|
|
(defun crdt--process-status-advice (orig-func process)
|
|
(if (crdt--pseudo-process-p process)
|
|
'run
|
|
(funcall orig-func process)))
|
|
|
|
(defun crdt--delete-process-advice (orig-func process)
|
|
(unless (crdt--pseudo-process-p process)
|
|
(funcall orig-func process)))
|
|
|
|
(defun crdt--process-buffer-advice (orig-func process)
|
|
(if (crdt--pseudo-process-p process)
|
|
(crdt--pseudo-process-buffer process)
|
|
(funcall orig-func process)))
|
|
|
|
(defun crdt--processp-advice (orig-func object)
|
|
(or (crdt--pseudo-process-p object) (funcall orig-func object)))
|
|
|
|
(defun crdt--dummy () nil)
|
|
|
|
(defun crdt--process-sentinel/filter-advice (orig-func process)
|
|
(if (crdt--pseudo-process-p process)
|
|
#'crdt--dummy
|
|
(funcall orig-func process)))
|
|
|
|
(defun crdt--set-process-sentinel/filter-advice (orig-func process func)
|
|
(if (crdt--pseudo-process-p process)
|
|
nil
|
|
(funcall orig-func process func)))
|
|
|
|
(defun crdt--process-query-on-exit-flag-advice (orig-func process)
|
|
(unless (crdt--pseudo-process-p process)
|
|
(funcall orig-func process)))
|
|
|
|
(defun crdt--set-process-query-on-exit-flag-advice (orig-func process)
|
|
(unless (crdt--pseudo-process-p process)
|
|
(funcall orig-func process)))
|
|
|
|
(defvar crdt--process-advice-alist
|
|
'((process-send-string . crdt--process-send-string-advice)
|
|
(process-send-region . crdt--process-send-region-advice)
|
|
(processp . crdt--processp-advice)
|
|
(get-buffer-process . crdt--get-buffer-process-advice)
|
|
(get-process . crdt--get-process-advice)
|
|
(process-status . crdt--process-status-advice)
|
|
(process-buffer . crdt--process-buffer-advice)
|
|
(process-mark . crdt--process-mark-advice)
|
|
(delete-process . crdt--delete-process-advice)
|
|
(process-name . crdt--process-name-advice)
|
|
(process-sentinel . crdt--process-sentinel/filter-advice)
|
|
(process-filter . crdt--process-sentinel/filter-advice)
|
|
(set-process-sentinel . crdt--set-process-sentinel/filter-advice)
|
|
(set-process-filter . crdt--set-process-sentinel/filter-advice)
|
|
(process-query-on-exit-flag . crdt--process-query-on-exit-flag-advice)
|
|
(process-set-query-on-exit-flag . crdt--set-process-query-on-exit-flag-advice)))
|
|
|
|
(defun crdt--install-process-advices ()
|
|
"Globally enable advices for simulating remote buffer process.
|
|
Those advices seem to possibly interfere with other packages.
|
|
Use CRDT--UNINSTALL-PROCESS-ADVICES to disable those advices for the rescue."
|
|
(dolist (pair crdt--process-advice-alist)
|
|
(advice-add (car pair) :around (cdr pair))))
|
|
|
|
(defun crdt--uninstall-process-advices ()
|
|
"Globally disable advices for simulating remote buffer process."
|
|
(dolist (pair crdt--process-advice-alist)
|
|
(advice-remove (car pair) (cdr pair))))
|
|
|
|
(crdt--install-process-advices)
|
|
|
|
(define-crdt-message-handler process (buffer-name string)
|
|
(crdt--with-buffer-name buffer-name
|
|
(process-send-string (get-buffer-process (current-buffer)) string)))
|
|
|
|
;;; Built-in package integrations
|
|
|
|
;;;; Org
|
|
(define-minor-mode crdt-org-sync-overlay-mode
|
|
"Minor mode to synchronize hidden `org-mode' subtrees."
|
|
:lighter " Sync Org Overlay"
|
|
(if crdt-org-sync-overlay-mode
|
|
(progn
|
|
(save-excursion
|
|
(save-restriction
|
|
(widen)
|
|
;; heuristic to remove existing org overlays
|
|
(cl-loop for ov in (overlays-in (point-min) (point-max))
|
|
do (when (memq (overlay-get ov 'invisible)
|
|
'(outline org-hide-block))
|
|
(delete-overlay ov)))))
|
|
(crdt--enable-overlay-species 'org))
|
|
(crdt--disable-overlay-species 'org)))
|
|
|
|
(defun crdt--org-overlay-advice (orig-fun &rest args)
|
|
(if crdt-org-sync-overlay-mode
|
|
(let ((crdt--track-overlay-species 'org))
|
|
(apply orig-fun args))
|
|
(apply orig-fun args)))
|
|
|
|
(cl-loop for command in '(org-cycle org-shifttab)
|
|
do (advice-add command :around #'crdt--org-overlay-advice))
|
|
|
|
;;;; xscheme
|
|
(defvar crdt-xscheme-fcaps
|
|
(crdt-make-local-fcaps
|
|
'((xscheme-send-region (region))
|
|
(xscheme-send-definition (point))
|
|
(xscheme-send-previous-expression (point))
|
|
(xscheme-send-next-expression (point))
|
|
(xscheme-send-current-line (point))
|
|
(xscheme-send-buffer)
|
|
(xscheme-send-char)
|
|
(xscheme-delete-output)
|
|
(xscheme-send-breakpoint-interrupt)
|
|
(xscheme-send-proceed)
|
|
(xscheme-send-control-g-interrupt)
|
|
(xscheme-send-control-u-interrupt)
|
|
(xscheme-send-control-x-interrupt)
|
|
(scheme-debugger-self-insert (last-command-event)))))
|
|
;; xscheme doesn't use standard DEFINE-*-MODE facility
|
|
;; and doesn't call after-change-major-mode-hook.
|
|
;; Therefore we have to hack.
|
|
(advice-add 'scheme-interaction-mode-initialize :after 'crdt--after-change-major-mode)
|
|
(advice-add 'scheme-debugger-mode-initialize :after
|
|
(lambda () ;; haxxxx!!!!
|
|
(let ((major-mode 'scheme-debugger-mode-initialize))
|
|
(crdt--after-change-major-mode))))
|
|
;; I can't get input prompt from debugger to pop up at the right place.
|
|
;; Because it's done asynchronously in process filter,
|
|
;; and there seems to be no way to know the correct SPAWN-SITE-ID.
|
|
|
|
;;;; comint
|
|
(require 'ring)
|
|
(defvar comint-input-ring)
|
|
(defvar comint-input-ignoredups)
|
|
(defvar comint-input-ring-size)
|
|
(defvar comint-input-ring-file-name)
|
|
|
|
(defvar crdt-comint-fcaps
|
|
(crdt-make-local-fcaps
|
|
'((comint-send-input (point) (point))
|
|
(comint-send-region (region) (region))
|
|
(comint-send-eof (point)))))
|
|
|
|
(crdt-register-autoload 'shell-mode 'shell)
|
|
(crdt-register-autoload 'inferior-scheme-mode 'cmuscheme)
|
|
(crdt-register-autoload 'inferior-python-mode 'python)
|
|
(crdt-register-autoload 'prolog-inferior-mode 'prolog)
|
|
(crdt-register-autoload 'inferior-lisp-mode 'inf-lisp)
|
|
|
|
(put 'comint-input-ring 'crdt-variable-scheme crdt-variable-scheme-diff-server)
|
|
|
|
(defcustom crdt-comint-share-input-history 'censor
|
|
"Share comint input history.
|
|
If the value is 'censor,
|
|
show only input history generated during a CRDT session to its peers,
|
|
Merge with history generated before the session after the buffer is no longer shared."
|
|
:type '(choice boolean (const censor)))
|
|
|
|
(defvar-local crdt--comint-saved-input-ring nil)
|
|
|
|
(defun crdt--merge-ring (old-ring delta-ring nodups)
|
|
"Construct a new ring by merging OLD-RING and DELTA-RING.
|
|
If NODUPS is non-nil, don't duplicate existing items in OLD-RING.
|
|
This procedure is non-destructive."
|
|
(if delta-ring
|
|
(let ((old-ring (copy-tree old-ring t)))
|
|
(cl-loop for i from (1- (ring-length delta-ring)) downto 0
|
|
for item = (ring-ref delta-ring i)
|
|
do (if nodups
|
|
(let ((index (ring-member old-ring item)))
|
|
(when index
|
|
(ring-remove old-ring index))
|
|
(ring-insert old-ring item))
|
|
(ring-insert old-ring item)))
|
|
old-ring)
|
|
old-ring))
|
|
|
|
(defsubst crdt--comint-effective-ring ()
|
|
(if crdt--comint-saved-input-ring
|
|
(crdt--merge-ring crdt--comint-saved-input-ring comint-input-ring comint-input-ignoredups)
|
|
comint-input-ring))
|
|
|
|
(defun crdt--comint-mode-hook ()
|
|
(when (derived-mode-p 'comint-mode)
|
|
(if crdt-mode
|
|
(progn
|
|
(add-to-list 'crdt--enabled-text-properties 'field)
|
|
(add-to-list 'crdt--enabled-text-properties 'front-sticky)
|
|
(add-to-list 'crdt--enabled-text-properties 'rear-nonsticky)
|
|
(if (crdt--server-p)
|
|
(when crdt-comint-share-input-history
|
|
(crdt-register-variable 'comint-input-ring crdt-variable-scheme-diff-server)
|
|
(when (eq crdt-comint-share-input-history 'censor)
|
|
(cl-shiftf crdt--comint-saved-input-ring comint-input-ring
|
|
(make-ring comint-input-ring-size))))
|
|
(crdt-register-variable 'comint-input-ring crdt-variable-scheme-diff-server)
|
|
(setq comint-input-ring-file-name nil)))
|
|
(setq comint-input-ring (crdt--comint-effective-ring)
|
|
crdt--comint-saved-input-ring nil))))
|
|
|
|
(defun crdt--comint-write-input-ring-advice (orig-func)
|
|
(if crdt-mode
|
|
(let ((comint-input-ring (crdt--comint-effective-ring)))
|
|
(funcall orig-func))
|
|
(funcall orig-func)))
|
|
|
|
(add-hook 'comint-mode-hook #'crdt--comint-mode-hook)
|
|
(add-hook 'crdt-mode-hook #'crdt--comint-mode-hook)
|
|
|
|
;;;; xref
|
|
(defvar crdt-xref-fcaps
|
|
(crdt-make-local-fcaps
|
|
`((xref-find-definitions (point) (point window)
|
|
,(crdt-make-interactive-proxy 'xref-find-definitions))
|
|
(xref-find-references (point) (point window)
|
|
,(crdt-make-interactive-proxy 'xref-find-references))
|
|
(xref-show-location-at-point (point) (point))
|
|
(xref-pop-marker-stack () (point))
|
|
(xref-goto-xref (point) (point window)))))
|
|
|
|
(defun crdt--xref-buffer-mode-hook ()
|
|
(add-to-list 'crdt--enabled-text-properties 'xref-item)
|
|
(add-to-list 'crdt--enabled-text-properties 'xref-group))
|
|
|
|
(provide 'crdt)
|
|
;;; crdt.el ends here
|