;;; crdt.el --- collaborative editing using Conflict-free Replicated Data Types  -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020 Qiantan Hong
;;
;; Author: Qiantan Hong <qhong@mit.edu>
;; Maintainer: Qiantan Hong <qhong@mit.edu>
;; Keywords: collaboration crdt
;; Version: 0.0.0
;;
;; crdt.el 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.
;;
;; crdt.el 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 crdt.el.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;; This package provides a collaborative editing environment for Emacs.

;;; Code:

;;; Customs

(defgroup crdt nil
  "Collaborative editing using Conflict-free Replicated Data Types."
  :prefix "crdt-"
  :group 'applications)

(defcustom crdt-ask-for-name t
  "Ask for display name everytime a CRDT session is to be started or connected."
  :type 'boolean)

(defcustom crdt-default-name (user-full-name)
  "Default display name."
  :type 'string)

(defcustom crdt-ask-for-password t
  "Ask for server password everytime a CRDT server is to be started."
  :type 'boolean)

(defcustom crdt-confirm-stop-session t
  "Ask for confirmation when a CRDT server with some client connected is to be stopped."
  :type 'boolean)

(defvar crdt--log-network-traffic nil
  "Debug switch to log network traffic to *Messages*.")

(require 'files)

(defcustom crdt-tuntox-executable (executable-find "tuntox")
  "Path to the tuntox binary."
  :type 'file)

(defcustom crdt-tuntox-key-path (expand-file-name "~")
  "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)))

(require 'cl-lib)
(require 'subr-x)
(require 'url)

;;; Pseudo cursor/region utils

(require 'color)

(defvar crdt-cursor-region-colors
  (let ((n 10))
    (cl-loop for i below n
          for hue by (/ 1.0 n)
          collect (cons
                   (apply #'color-rgb-to-hex
                          (color-hsl-to-rgb hue 0.5 0.5))
                   (apply #'color-rgb-to-hex
                          (color-hsl-to-rgb hue 0.2 0.5))))))

(defun crdt--get-cursor-color (site-id)
  "Get cursor color for SITE-ID."
  (car (nth (mod site-id (length crdt-cursor-region-colors)) crdt-cursor-region-colors)))

(defun crdt--get-region-color (site-id)
  "Get region color for SITE-ID."
  (cdr (nth (mod site-id (length crdt-cursor-region-colors)) crdt-cursor-region-colors)))

(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 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."
  `(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."
  `(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--session (:constructor crdt--make-session))
  local-id ; Local site-id
  local-clock ; Local logical clock
  contact-table ; A hash table that maps SITE-ID to CRDT--CONTACT-METADATAs
  local-name
  name
  focused-buffer-name
  user-menu-buffer
  buffer-menu-buffer
  network-process
  network-clients
  next-client-id
  buffer-table)

(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)

(crdt--defvar-permanent-local crdt--last-point nil)

(crdt--defvar-permanent-local crdt--last-mark nil)

(crdt--defvar-permanent-local crdt--pseudo-cursor-table nil
                              "A hash table that maps SITE-ID to CONSes of the form (CURSOR-OVERLAY . REGION-OVERLAY).")

(cl-defstruct (crdt--contact-metadata
                (:constructor crdt--make-contact-metadata (display-name focused-buffer-name host service)))
  display-name host service focused-buffer-name)

(cl-defstruct (crdt--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 (SITE-ID . LOGICAL-CLOCK) to overlays.")

(defvar crdt--track-overlay-species nil)

(crdt--defvar-permanent-local crdt--enabled-overlay-species nil)

(crdt--defvar-permanent-local crdt--buffer-network-name)

(crdt--defvar-permanent-local crdt--buffer-sync-callback)

;;; Global variables

(defvar crdt--session-list nil)

(defvar crdt--session-menu-buffer nil)

;;; crdt-mode

(defun crdt--install-hooks ()
  "Install the hooks used by CRDT-MODE."
  (add-hook 'after-change-functions #'crdt--after-change nil t)
  (add-hook 'before-change-functions #'crdt--before-change nil t)
  (add-hook 'post-command-hook #'crdt--post-command nil t)
  (add-hook 'deactivate-mark-hook #'crdt--post-command nil t)
  (add-hook 'kill-buffer-hook #'crdt--kill-buffer-hook nil t))

(defun crdt--uninstall-hooks ()
  "Uninstall the hooks used by CRDT-MODE."
  (remove-hook 'after-change-functions #'crdt--after-change t)
  (remove-hook 'before-change-functions #'crdt--before-change t)
  (remove-hook 'post-command-hook #'crdt--post-command t)
  (remove-hook 'deactivate-mark-hook #'crdt--post-command t)
  (remove-hook 'kill-buffer-hook #'crdt--kill-buffer-hook 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)))

(define-minor-mode crdt-mode
    "CRDT mode" nil " CRDT" nil
    (if crdt-mode
        (progn
          (setq crdt--pseudo-cursor-table (make-hash-table))
          (setq crdt--overlay-table (make-hash-table :test 'equal))
          (crdt--install-hooks))
      (crdt--uninstall-hooks)
      (crdt--clear-pseudo-cursor-table)
      (setq crdt--overlay-table nil)))

;;; Shared buffer utils

(defsubst crdt--server-p (&optional session)
  "Tell if SESSION is running as a server.
If SESSION is nil, use current CRDT--SESSION."
  (process-contact
   (crdt--session-network-process
    (or session crdt--session))
   :server))

(defmacro crdt--with-buffer-name (name &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, do nothing."
  `(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
         ,@body))))

(defmacro crdt--with-buffer-name-pull (name &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."
  `(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 (process-contact (crdt--session-network-process crdt--session) :server)
         (setq crdt-buffer (generate-new-buffer (format "crdt - %s" ,name)))
         (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..."))
             (setq crdt--buffer-sync-callback
                   (lambda ()
                     ,@body))))))))

;;; Session menu

(defun crdt--session-menu-goto ()
  "Open the buffer menu for the session under point in CRDT session menu."
  (interactive)
  (let ((crdt--session (tabulated-list-get-id)))
    (crdt-list-buffers)))

(defun crdt--session-menu-kill ()
  "Kill the session under point in CRDT session menu."
  (interactive)
  (crdt--stop-session (tabulated-list-get-id)))

(defvar crdt-session-menu-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'crdt--session-menu-goto)
    (define-key map (kbd "k") #'crdt--session-menu-kill)
    map))

(define-derived-mode crdt-session-menu-mode tabulated-list-mode
  "CRDT User List"
  (setq tabulated-list-format [("Session Name" 15 t)
                               ("Role" 7 t)
                               ("My Name" 15 t)
                               ("Buffers" 30 t)
                               ("Users" 15 t)]))

(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-name 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))
                                              (let (users)
                                                (maphash (lambda (_ v)
                                                           (push (crdt--contact-metadata-display-name v) users))
                                                         (crdt--session-contact-table session))
                                                (cons (crdt--session-local-name session) users))
                                              ", ")))
             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--buffer-menu-goto ()
  "Open the buffer under point in CRDT buffer menu."
  (interactive)
  (let ((name (tabulated-list-get-id)))
    (crdt--with-buffer-name-pull name
     (switch-to-buffer-other-window (current-buffer)))))

(defun crdt--buffer-menu-kill ()
  "Stop sharing the buffer under point in CRDT buffer menu.
Only server can perform this action."
  (interactive)
  (if (crdt--server-p)
      (let ((name (tabulated-list-get-id)))
        (crdt--with-buffer-name name
         (crdt-stop-share-buffer)))
    (message "Only server can stop sharing a buffer.")))

(defvar crdt-buffer-menu-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'crdt--buffer-menu-goto)
    (define-key map (kbd "k") #'crdt--buffer-menu-kill)
    map))

(define-derived-mode crdt-buffer-menu-mode tabulated-list-mode
  "CRDT User List"
  (setq tabulated-list-format [("Local Buffer" 15 t)
                               ("Network Name" 30 t)
                               ("Users" 15 t)]))

(defun crdt-list-buffers (&optional crdt-buffer display-buffer)
  "Display a list of buffers shared in the current CRDT session.
If DISPLAY-BUFFER is provided, display the output there.
Otherwise use a dedicated buffer for displaying active users on CRDT-BUFFER."
  (interactive)
  (with-current-buffer (or crdt-buffer (current-buffer))
    (unless crdt--session
      (error "Not a CRDT shared buffer"))
    (unless display-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 (concat (crdt--session-name crdt--session)
                                           " buffers")))
        (crdt--assimilate-session (crdt--session-buffer-menu-buffer crdt--session)))
      (setq 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-display-name v)
                       (gethash (crdt--contact-metadata-focused-buffer-name v)
                                tmp-hashtable)))
               (crdt--session-contact-table crdt--session))
      (push (crdt--session-local-name crdt--session)
            (gethash (crdt--session-focused-buffer-name crdt--session)
                     tmp-hashtable))
      (maphash (lambda (k v)
                 (push (list k (vector (if (and v (buffer-live-p v))
                                           (buffer-name v)
                                         "--")
                                       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--user-menu-goto ()
  "Goto the cursor location of the user under point in CRDT user menu."
  (interactive)
  (let ((site-id (tabulated-list-get-id)))
    (if (eq site-id (crdt--session-local-id crdt--session))
        (switch-to-buffer-other-window
         (gethash (crdt--session-focused-buffer-name crdt--session) (crdt--session-buffer-table crdt--session)))
      (unless
          (cl-block nil
            (let* ((metadata (or (gethash site-id (crdt--session-contact-table crdt--session)) (cl-return)))
                   (buffer-name (or (crdt--contact-metadata-focused-buffer-name metadata) (cl-return))))
              (crdt--with-buffer-name-pull
               buffer-name
               (switch-to-buffer-other-window (current-buffer))
               (ignore-errors (goto-char (overlay-start (car (gethash site-id crdt--pseudo-cursor-table)))))
               t)))
        (message "Doesn't have position information for this user yet.")))))

(defvar crdt-user-menu-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'crdt--user-menu-goto)
    map))

(define-derived-mode crdt-user-menu-mode tabulated-list-mode
  "CRDT User List"
  (setq tabulated-list-format [("Display Name" 15 t)
                               ("Focused Buffer" 30 t)
                               ("Address" 15 t)]))

(defun crdt-list-users (&optional crdt-buffer display-buffer)
  "Display a list of active users working on a CRDT-shared buffer CRDT-BUFFER.
If DISPLAY-BUFFER is provided, display the output there.
Otherwise use a dedicated buffer for displaying active users on CRDT-BUFFER."
  (interactive)
  (with-current-buffer (or crdt-buffer (current-buffer))
    (unless crdt--session
      (error "Not a CRDT shared buffer"))
    (unless display-buffer
      (unless (and (crdt--session-user-menu-buffer crdt--session) (buffer-live-p (crdt--session-user-menu-buffer crdt--session)))
        (setf (crdt--session-user-menu-buffer crdt--session)
              (generate-new-buffer (concat (crdt--session-name crdt--session) " users")))
        (crdt--assimilate-session (crdt--session-user-menu-buffer crdt--session)))
      (setq 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)
    (push (list (crdt--session-local-id crdt--session)
                (vector (crdt--session-local-name crdt--session)
                        (or (crdt--session-focused-buffer-name crdt--session) "--")
                        "*myself*"))
          tabulated-list-entries)
    (maphash (lambda (k v)
               (push (list k (let ((name (crdt--contact-metadata-display-name v))
                                   (host (crdt--contact-metadata-host v))
                                   (service (crdt--contact-metadata-service v))
                                   (focused-buffer-name (or (crdt--contact-metadata-focused-buffer-name v) "--")))
                               (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 colored-name focused-buffer-name (format "%s:%s" host service)))))
                     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."
  (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--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
                              `(focus ,(crdt--session-local-id crdt--session) nil)))
      (setf (crdt--session-focused-buffer-name crdt--session) nil))
    (crdt--refresh-users-maybe)))

;;; CRDT insert/delete

(defsubst crdt--base64-encode-maybe (str)
  "Base64 encode STR if it's a string, or return NIL if STR is NIL."
  (when str (base64-encode-string str)))

(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 (resulting-commands)
    (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
                              ,(base64-encode-string virtual-id) ,beg
                              ,(buffer-substring-no-properties beg merge-end))
                     resulting-commands))
             (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--session-local-id crdt--session))))
           (put-text-property beg block-end 'crdt-id (cons new-id t))
           (push `(insert ,crdt--buffer-network-name
                          ,(base64-encode-string new-id) ,beg
                          ,(buffer-substring-no-properties beg block-end))
                 resulting-commands)
           (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-commands)))

(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."
  (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 pos '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 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."
  (let* ((beg (crdt--find-id id position-hint)) end)
    (save-excursion
      (goto-char beg)
      (insert content)
      (setq end (point))
      ;; work around for input method overlays
      (cl-loop for ov in (overlays-at beg)
            do (unless (overlay-get ov 'crdt-meta)
                 (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)
  )

(defun crdt--local-delete (beg end)
  "Handle local deletion event and return a message to be sent to other peers.
The deletion happens between BEG and END."
  (let ((outer-end end))
    (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
           ,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.
It saves the content to be changed (between BEG and END) into CRDT--CHANGED-STRING."
  (unless crdt--inhibit-update
    (setq crdt--changed-string (buffer-substring beg end))))

(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."
  (let (next-pos
        (pos 0)
        (limit (length template)))
    (while (< pos limit)
      (setq next-pos (next-single-property-change pos 'crdt-id template limit))
      (put-text-property (+ beg pos) (+ beg next-pos) 'crdt-id
                         (get-text-property pos 'crdt-id template)
                         object)
      (setq pos next-pos))))

(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 whose length shall equal to LENGTH)
and current content between BEG and END,
update the CRDT-ID for any newly inserted text,
and send message to other peers if needed."
  (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) ; LOCAL-ID is NIL when a client haven't received the first sync message
    (unless crdt--inhibit-update
      (let ((crdt--inhibit-update t))
        ;; we're only interested in text change
        ;; ignore property only changes
        (save-excursion
          (goto-char beg)
          (if (and (= length (- end beg))
                   (string-equal crdt--changed-string
                                 (buffer-substring-no-properties beg end)))
              (crdt--crdt-id-assimilate crdt--changed-string beg)
            (widen)
            (with-silent-modifications
              (unless (= length 0)
                (crdt--broadcast-maybe
                 (crdt--format-message (crdt--local-delete beg end))))
              (unless (= beg end)
                (dolist (message (crdt--local-insert beg end))
                  (crdt--broadcast-maybe
                   (crdt--format-message message)))))))))))

;;; 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 (site-id point-position-hint point-crdt-id mark-position-hint mark-crdt-id)
  "Handle remote cursor/mark movement message at SITE-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, deactivate the pseudo region overlay."
  (when (and site-id (not (eq site-id (crdt--session-local-id crdt--session))))
    (let ((ov-pair (gethash site-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 site-id)))
                (overlay-put new-cursor 'category 'crdt-pseudo-cursor)
                (overlay-put new-region 'face `(:background ,(crdt--get-region-color site-id) :extend t))
                (setq ov-pair (puthash site-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 ov-pair
          (remhash site-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)
      (let ((point-id-base64 (base64-encode-string (crdt--get-id point)))
            (mark-id-base64 (when mark (base64-encode-string (crdt--get-id mark)))))
        `(cursor ,crdt--buffer-network-name ,(crdt--session-local-id crdt--session)
                 ,point ,point-id-base64 ,mark ,mark-id-base64)))))

(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."
  (unless (eq crdt--buffer-network-name (crdt--session-focused-buffer-name crdt--session))
    (crdt--broadcast-maybe
     (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) ,crdt--buffer-network-name)))
    (setf (crdt--session-focused-buffer-name crdt--session) crdt--buffer-network-name))
  (let ((cursor-message (crdt--local-cursor)))
    (when cursor-message
      (crdt--broadcast-maybe (crdt--format-message cursor-message)))))


;;; 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-BASE64 END-OF-BLOCK-P),
or (LENGTH CRDT-ID-BASE64) 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) (buffer-substring-no-properties prev-pos pos))
                                ((bufferp object)
                                 (with-current-buffer object
                                   (buffer-substring-no-properties 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)
                        (let ((id-base64 (base64-encode-string id)))
                          (if omit-end-of-block-p (list id-base64) (list id-base64 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-base64 eob) id-item
      (insert (propertize content 'crdt-id
                          (cons (base64-decode-string id-base64) 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--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 T."
  (when crdt--log-network-traffic
    (message "Send %s" message-string))
  (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)))
          (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
      (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)
      )))

(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
                          (base64-encode-string (crdt--get-id beg))
                        (crdt--base64-encode-maybe (crdt--get-id (1- beg))))
                ,end ,(if rear-advance
                          (base64-encode-string (crdt--get-id end))
                        (crdt--base64-encode-maybe (crdt--get-id (1- end))))))

(defun 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 process)
  "Send messages to a client about the full state of BUFFER.
The network process for the client connection is PROCESS."
  (with-current-buffer buffer
    (process-send-string process (crdt--format-message `(sync
                                                         ,crdt--buffer-network-name
                                                         ,@ (crdt--dump-ids (point-min) (point-max) nil nil t))))
    ;; synchronize cursor
    (maphash (lambda (site-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))
                        (point-id-base64 (base64-encode-string (crdt--get-id point)))
                        (mark-id-base64 (when mark (base64-encode-string (crdt--get-id mark)))))
                   (process-send-string process
                                        (crdt--format-message
                                         `(cursor ,crdt--buffer-network-name ,site-id
                                                  ,point ,point-id-base64 ,mark ,mark-id-base64))))))
             crdt--pseudo-cursor-table)
    (process-send-string 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
                  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
                           process
                           (crdt--format-message `(overlay-put ,crdt--buffer-network-name
                                                               ,(car k) ,(cdr k) ,prop ,value))))))
             crdt--overlay-table)

    (process-send-string process (crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode)))))

(defun crdt--greet-client (process)
  "Send initial information when a client connects.
Those information include the assigned SITE-ID, buffer list,
and contact data of other users.
The network process for the client connection is PROCESS."
  (let ((crdt--session (process-get process 'crdt-session)))
    (cl-pushnew process (crdt--session-network-clients crdt--session))
    (let ((client-id (process-get process 'client-id)))
      (unless client-id
        (unless (< (crdt--session-next-client-id crdt--session) crdt--max-value)
          (error "Used up client IDs.  Need to implement allocation algorithm"))
        (process-put process 'client-id (crdt--session-next-client-id crdt--session))
        (setq client-id (crdt--session-next-client-id crdt--session))
        (process-send-string process (crdt--format-message
                                      `(login ,client-id
                                              ,(crdt--session-name crdt--session))))
        (cl-incf (crdt--session-next-client-id crdt--session)))
      (process-send-string process (crdt--format-message
                                    (cons 'add (hash-table-keys (crdt--session-buffer-table crdt--session)))))
      ;; synchronize contact
      (maphash (lambda (k v)
                 (process-send-string
                  process (crdt--format-message `(contact ,k ,(crdt--contact-metadata-display-name v)
                                                          ,(crdt--contact-metadata-host v)
                                                          ,(crdt--contact-metadata-service v))))
                 (process-send-string
                  process (crdt--format-message `(focus ,k ,(crdt--contact-metadata-focused-buffer-name v)))))
               (crdt--session-contact-table crdt--session))
      (process-send-string process
                           (crdt--format-message `(contact ,(crdt--session-local-id crdt--session)
                                                           ,(crdt--session-local-name crdt--session))))
      (process-send-string process
                           (crdt--format-message `(focus ,(crdt--session-local-id crdt--session)
                                                         ,(crdt--session-focused-buffer-name crdt--session))))
      (let ((contact-message `(contact ,client-id ,(process-get process 'client-name)
                                       ,(process-contact process :host)
                                       ,(process-contact process :service))))
        (crdt-process-message contact-message process)))))

(cl-defgeneric crdt-process-message (message process) "Handle MESSAGE received from PROCESS.")

(cl-defmethod crdt-process-message (message process)
  (message "Unrecognized message %S from %s:%s."
           message (process-contact process :host) (process-contact process :service)))

(cl-defmethod crdt-process-message ((message (head insert)) process)
  (cl-destructuring-bind (buffer-name crdt-id position-hint content) (cdr message)
    (crdt--with-buffer-name
     buffer-name
     (crdt--remote-insert (base64-decode-string crdt-id) position-hint content)))
  (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id)))

(cl-defmethod crdt-process-message ((message (head delete)) process)
  (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))
  (cl-destructuring-bind (buffer-name position-hint . id-base64-pairs) (cdr message)
    (mapc (lambda (p) (rplaca (cdr p) (base64-decode-string (cadr p)))) id-base64-pairs)
    (crdt--with-buffer-name
     buffer-name
     (crdt--remote-delete position-hint id-base64-pairs))))

(cl-defmethod crdt-process-message ((message (head cursor)) process)
  (cl-destructuring-bind (buffer-name site-id point-position-hint point-crdt-id
                                      mark-position-hint mark-crdt-id)
      (cdr message)
    (crdt--with-buffer-name
     buffer-name
     (crdt--remote-cursor site-id point-position-hint
                          (and point-crdt-id (base64-decode-string point-crdt-id))
                          mark-position-hint
                          (and mark-crdt-id (base64-decode-string mark-crdt-id)))))
  (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id)))

(cl-defmethod crdt-process-message ((message (head get)) process)
  (cl-destructuring-bind (buffer-name) (cdr message)
    (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)
        (process-send-string process (crdt--format-message `(remove ,buffer-name)))))))

(cl-defmethod crdt-process-message ((message (head sync)) _process)
  (unless (crdt--server-p)             ; server shouldn't receive this
    (cl-destructuring-bind (buffer-name . ids) (cdr message)
      (crdt--with-buffer-name
       buffer-name
       (let ((crdt--inhibit-update 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-max)))))))
         (erase-buffer)
         (crdt--load-ids ids))))
    (crdt--refresh-buffers-maybe)))

(cl-defmethod crdt-process-message ((message (head ready)) _process)
  (unless (crdt--server-p)             ; server shouldn't receive this
    (cl-destructuring-bind (buffer-name mode) (cdr message)
      (crdt--with-buffer-name
       buffer-name
       (if (fboundp mode)
           (unless (eq major-mode mode)
             (funcall mode)            ; trust your server...
             (crdt-mode))
         (message "Server uses %s, but not available locally." mode))
       (when crdt--buffer-sync-callback
         (funcall crdt--buffer-sync-callback)
         (setq crdt--buffer-sync-callback nil))))))

(cl-defmethod crdt-process-message ((message (head add)) _process)
  (dolist (buffer-name (cdr message))
    (unless (gethash buffer-name (crdt--session-buffer-table crdt--session))
      (puthash buffer-name nil (crdt--session-buffer-table crdt--session)))
    (crdt--refresh-buffers-maybe)))

(cl-defmethod crdt-process-message ((message (head remove)) process)
  (let ((saved-session crdt--session))
    (dolist (buffer-name (cdr message))
      (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 crdt--session nil))))))
   (message "Server stopped sharing %s."
            (mapconcat #'identity (cdr message) ", "))
   (let ((crdt--session saved-session))
     (crdt--broadcast-maybe (crdt--format-message message)
                            (when process (process-get process 'client-id)))
     (crdt--refresh-buffers-maybe))))

(cl-defmethod crdt-process-message ((message (head login)) process)
  (cl-destructuring-bind (id session-name) (cdr message)
    (puthash 0 (crdt--make-contact-metadata nil nil
                                            (process-contact process :host)
                                            (process-contact process :service))
             (crdt--session-contact-table crdt--session))
    (setf (crdt--session-name crdt--session) (concat session-name "@" (crdt--session-name crdt--session)))
    (setf (crdt--session-local-id crdt--session) id)
    (crdt--refresh-sessions-maybe)))

(cl-defmethod crdt-process-message ((_message (head leave)) process)
  (delete-process process))

(cl-defmethod crdt-process-message ((message (head challenge)) _process)
  (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--session-local-name crdt--session)
                                      ,(gnutls-hash-mac 'SHA1 password (cadr message))))))))

(cl-defmethod crdt-process-message ((message (head contact)) process)
  (cl-destructuring-bind
        (site-id display-name &optional host service) (cdr message)
    (if display-name
        (if host
            (puthash site-id (crdt--make-contact-metadata
                              display-name nil host service)
                     (crdt--session-contact-table crdt--session))
          (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session))))
            (setf (crdt--contact-metadata-display-name existing-item) display-name)))
      (remhash site-id (crdt--session-contact-table crdt--session)))
    (crdt--refresh-users-maybe))
  (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id)))

(cl-defmethod crdt-process-message ((message (head focus)) process)
  (cl-destructuring-bind
        (site-id buffer-name) (cdr message)
    (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session))))
      (setf (crdt--contact-metadata-focused-buffer-name existing-item) buffer-name))
    ;; (when (and (= site-id 0) (not crdt--focused-buffer-name))
    ;;   (setq crdt--focused-buffer-name buffer-name)
    ;;   (switch-to-buffer (gethash buffer-name (crdt--session-buffer-table crdt--session))))
    (crdt--refresh-users-maybe))
  (crdt--broadcast-maybe (crdt--format-message message) (process-get process '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*"))
    (set-marker (process-mark process) 1))
  (with-current-buffer (process-buffer process)
    (unless crdt--session
      (setq crdt--session (process-get process 'crdt-session)))
    (save-excursion
      (goto-char (process-mark process))
      (insert string)
      (set-marker (process-mark process) (point))
      (goto-char (point-min))
      (let (message)
        (while (setq message (ignore-errors (read (current-buffer))))
          (when crdt--log-network-traffic
            (print message))
          (cl-macrolet ((body ()
                          '(if (or (not (crdt--server-p)) (process-get process 'authenticated))
                            (let ((crdt--inhibit-update t))
                              (crdt-process-message message process))
                            (cl-block nil
                              (when (eq (car message) 'hello)
                                (cl-destructuring-bind (name &optional response) (cdr message)
                                  (when (or (not (process-get process 'password)) ; server password is empty
                                            (and response (string-equal response (process-get process 'challenge))))
                                    (process-put process 'authenticated t)
                                    (process-put process 'client-name name)
                                    (crdt--greet-client process)
                                    (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))))))))
            (if debug-on-error (body)
              (condition-case err (body)
                (error (message "%s error when processing message from %s:%s, disconnecting." err
                                (process-contact process :host) (process-contact process :service))
                       (if (crdt--server-p)
                           (delete-process process)
                         (crdt--stop-session crdt--session))))))
          (delete-region (point-min) (point))
          (goto-char (point-min)))))))

(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)))
      (when (process-buffer client) (kill-buffer (process-buffer client)))
      ;; generate a clear cursor message and a clear contact message
      (let* ((client-id (process-get client 'client-id))
             (clear-contact-message `(contact ,client-id nil)))
        (crdt-process-message clear-contact-message client)
        (maphash
         (lambda (k _)
           (crdt-process-message
            `(cursor ,k ,client-id 1 nil 1 nil)
            client))
         (crdt--session-buffer-table crdt--session))
        (crdt--refresh-users-maybe)))))

(defun crdt--client-process-sentinel (process _message)
  (unless (eq (process-status process) 'open)
    (when (process-get process 'tuntox-process)
      (process-send-string process (crdt--format-message '(leave))))
    (crdt--stop-session (process-get process 'crdt-session))))

;;; UI commands

(defun crdt--read-name (&optional session-name)
  "Read display name from minibuffer or use the default display name.
The behavior is controlled by CRDT-ASK-FOR-NAME.
SESSION-NAME if provided is used in the prompt."
  (if crdt-ask-for-name
      (let ((input (read-from-minibuffer
                    (format "Display name%s (default %S): "
                            (if session-name (concat " for " session-name) "")
                            crdt-default-name))))
        (if (> (length input) 0) input crdt-default-name))
    crdt-default-name))

(defun crdt--share-buffer (buffer session)
  "Add BUFFER to CRDT SESSION."
  (if (process-contact (crdt--session-network-process session) :server)
      (with-current-buffer buffer
        (setq crdt--session session)
        (puthash (buffer-name buffer) buffer (crdt--session-buffer-table crdt--session))
        (setq crdt--buffer-network-name (buffer-name buffer))
        (crdt-mode)
        (save-excursion
          (widen)
          (let ((crdt--inhibit-update t))
            (with-silent-modifications
              (crdt--local-insert (point-min) (point-max))))
          (crdt--broadcast-maybe
           (crdt--format-message `(add
                                   ,crdt--buffer-network-name))))
        (add-hook 'kill-buffer-hook #'crdt-stop-share-buffer nil t)
        (crdt--refresh-buffers-maybe)
        (crdt--refresh-sessions-maybe))
    (error "Only server can add new buffer")))

(defsubst crdt--get-session-names (server)
  "Get session names for CRDT sessions (as in 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-name 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-name))

(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.
If SESSION-NAME is empty, use the buffer name of the current buffer."
  (interactive
   (progn
     (when (and crdt-mode crdt--session)
       (error "Current buffer is already shared in a CRDT session"))
     (list (let* ((session-names (crdt--get-session-names t))
                  (default-name (concat crdt-default-name ":" (buffer-name (current-buffer))))
                  (session-name (if session-names
                                    (completing-read "Choose a server session (create if not exist): "
                                                     session-names)
                                  (read-from-minibuffer
                                   (format "New session name (default %s): " default-name)))))
             (unless (and session-name (> (length session-name) 0))
               (setq session-name default-name))
             session-name))))
  (let ((session (crdt--get-session session-name)))
    (if session
        (crdt--share-buffer (current-buffer) session)
      (let ((port (read-from-minibuffer "Create new session on port (default 6530): " nil nil t nil "6530")))
        (when (not (numberp port))
          (error "Port must be a number"))
        (crdt--share-buffer (current-buffer) (crdt-new-session port session-name))))))

(defun crdt-stop-share-buffer ()
  "Stop sharing the current buffer."
  (interactive)
  (if crdt--session
      (if (crdt--server-p)
          (let ((buffer-name crdt--buffer-network-name))
            (let ((remove-message `(remove ,buffer-name)))
              (crdt-process-message remove-message nil)))
        (message "Only server can stop sharing a buffer."))
    (message "Not a CRDT shared buffer.")))

(defun crdt-new-session (port session-name &optional password display-name)
  "Start a new CRDT session on PORT with SESSION-NAME.
Setup up the server with PASSWORD and assign this Emacs DISPLAY-NAME."
  (let* ((network-process (make-network-process
                           :name "CRDT Server"
                           :server t
                           :family 'ipv4
                           :host "0.0.0.0"
                           :service port
                           :filter #'crdt--network-filter
                           :sentinel #'crdt--server-process-sentinel))
         (new-session
          (crdt--make-session :local-id 0
                              :local-clock 0
                              :next-client-id 1
                              :local-name (or display-name (crdt--read-name))
                              :contact-table (make-hash-table :test 'equal)
                              :buffer-table (make-hash-table :test 'equal)
                              :name session-name
                              :network-process network-process))
         (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)
    (unless password
      (setq password
            (when crdt-ask-for-password
              (read-from-minibuffer "Set password (empty for no authentication): "))))
    (if tuntox-p
        (let ((proxy-process
               (make-process :name "Tuntox Proxy"
                             :buffer (generate-new-buffer "*Tuntox Proxy*")
                             :command
                             `(,crdt-tuntox-executable
                               "-C" ,crdt-tuntox-key-path
                               "-f" "/dev/stdin" ; do the filtering for safety sake
                               ,@ (when (and password (> (length password) 0))
                                    `("-s" ,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)
          (switch-to-buffer-other-window (process-buffer proxy-process)))
      (when (and password (> (length password) 0))
        (process-put network-process 'password password)))
    new-session))

(defun crdt--stop-session (session)
  "Kill the CRDT SESSION.
Disconnect if it's a client session, or stop serving if it's a server session."
  (when (if (and crdt-confirm-stop-session
                 (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 ((proxy-process (process-get (crdt--session-network-process session) 'tuntox-process)))
      (when (and proxy-process (process-live-p proxy-process))
        (interrupt-process proxy-process)))
    (delete-process (crdt--session-network-process session))
    (message "Disconnected.")))

(defun crdt-stop-session (&optional session-name)
  "Stop sharing the session with SESSION-NAME.
If SESSION-NAME is nil, stop sharing the current session."
  (interactive
   (list (completing-read "Choose a server session: "
                          (crdt--get-session-names t) nil t
                          (when (and crdt--session (crdt--server-p))
                            (crdt--session-name crdt--session)))))
  (let ((session (if session-name
                     (crdt--get-session session-name)
                   crdt--session)))
    (crdt--stop-session session)))

(defun crdt-copy-url (&optional session-name)
  "Copy the url for the session with SESSION-NAME.
Currently this only work if a tuntox proxy is used."
  (interactive
   (list (completing-read "Choose a server session: "
                          (crdt--get-session-names t) nil t
                          (when (and crdt--session (crdt--server-p))
                            (crdt--session-name crdt--session)))))
  (let* ((session (if session-name
                     (crdt--get-session session-name)
                    crdt--session))
         (network-process (crdt--session-network-process session))
         (tuntox-process (process-get network-process 'tuntox-process)))
    (if tuntox-process
        (progn
          (kill-new (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)))
          (message "URL copied."))
      (message "No known URL to copy, find out your public IP address yourself!"))))

(defun crdt-disconnect (&optional session-name)
  "Disconnect from the session with SESSION-NAME.
If SESSION-NAME is nil, disconnect from the current session."
  (interactive
   (list (completing-read "Choose a client session: "
                          (crdt--get-session-names nil) nil t
                          (when (and crdt--session (not (crdt--server-p crdt--session)))
                            (crdt--session-name crdt--session)))))
  (let ((session (if session-name
                     (crdt--get-session session-name)
                   crdt--session)))
    (crdt--stop-session session)))

(defvar crdt-connect-url-history nil)

(defun crdt-connect (url &optional display-name)
  "Connect to a CRDT server running at URL.
Open a new buffer to display the shared content.
Join with DISPLAY-NAME."
  (interactive
   (list
    (let (parsed-url
          (url (read-from-minibuffer "URL: " nil nil nil 'crdt-connect-url-history)))
      (when (eq (length url) 0)
        (error "Please input a valid URL"))
      (setq parsed-url (url-generic-parse-url url))
      (unless (url-type parsed-url)
        (setq parsed-url (url-generic-parse-url (concat "tcp://" url))))
      (when (and (not (url-portspec parsed-url)) (member (url-type parsed-url) '("tcp" "tuntox")))
        (let ((port (read-from-minibuffer "Server port (default 6530): " nil nil t nil "6530")))
          (when (not (numberp port))
            (error "Port must be a number"))
          (setf (url-portspec parsed-url) port)))
      parsed-url)))
  (let ((url-type (url-type url))
        address port)
    (cl-macrolet ((start-session (&body body)
                    `(let* ((network-process (make-network-process
                                              :name "CRDT Client"
                                              :buffer (generate-new-buffer "*crdt-client*")
                                              :host address
                                              :family 'ipv4
                                              :service port
                                              :filter #'crdt--network-filter
                                              :sentinel #'crdt--client-process-sentinel))
                            (name-placeholder (format "%s:%s" address port))
                            (new-session
                             (crdt--make-session :local-clock 0
                                                 :local-name (or display-name (crdt--read-name name-placeholder))
                                                 :contact-table (make-hash-table :test 'equal)
                                                 :buffer-table (make-hash-table :test 'equal)
                                                 :name name-placeholder
                                                 :network-process network-process)))
                      (process-put network-process 'crdt-session new-session)
                      (push new-session crdt--session-list)
                      ,@body
                      (process-send-string network-process
                       (crdt--format-message `(hello ,(crdt--session-local-name new-session))))
                      (let ((crdt--session new-session))
                        (crdt-list-buffers)))))
      (cond ((equal url-type "tcp")
             (setq address (url-host url))
             (setq port (url-portspec url))
             (start-session))
            ((equal url-type "tuntox")
             (setq address "127.0.0.1")
             (setq port (read-from-minibuffer (format "tuntox proxy port (default %s): " (1+ (url-portspec url)))
                                              nil nil t nil (format "%s" (1+ (url-portspec url)))))
             (let ((password (read-passwd "tuntox password (empty for no password): ")))
               (switch-to-buffer-other-window
                (process-buffer
                 (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)
                      (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)
                                  (start-session (process-put network-process 'tuntox-process proc)))))
                            (if moving (goto-char (process-mark proc)))))))))))))
            (t (error "Unknown protocol \"%s\"" url-type))))))

;;; 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))

(cl-defmethod crdt-process-message ((message (head overlay-add)) process)
  (cl-destructuring-bind
        (buffer-name site-id logical-clock species
                     front-advance rear-advance start-hint start-id-base64 end-hint end-id-base64)
      (cdr message)
    (crdt--with-buffer-name
     buffer-name
     (let* ((crdt--track-overlay-species nil)
            (start (crdt--find-id (base64-decode-string start-id-base64) start-hint front-advance))
            (end (crdt--find-id (base64-decode-string end-id-base64) end-hint rear-advance))
            (new-overlay
             (make-overlay start end nil front-advance rear-advance))
            (key (cons site-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--format-message message) (process-get process '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
                                       (base64-encode-string (crdt--get-id beg))
                                     (crdt--base64-encode-maybe (crdt--get-id (1- beg))))
                             ,end ,(if rear-advance
                                       (base64-encode-string (crdt--get-id end))
                                     (crdt--base64-encode-maybe (crdt--get-id (1- end))))))))))))
  (apply orig-fun ov beg end args))

(cl-defmethod crdt-process-message ((message (head overlay-move)) process)
  (cl-destructuring-bind (buffer-name site-id logical-clock
                                      start-hint start-id-base64 end-hint end-id-base64)
      (cdr message)
    (crdt--with-buffer-name
     buffer-name
     (let* ((key (cons site-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 (base64-decode-string start-id-base64) start-hint front-advance))
                (end (crdt--find-id (base64-decode-string end-id-base64) end-hint rear-advance)))
           (let ((crdt--inhibit-overlay-advices t))
             (move-overlay ov start end)))))))
  (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id)))

(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))

(cl-defmethod crdt-process-message ((message (head overlay-remove)) process)
  (cl-destructuring-bind (buffer-name site-id logical-clock) (cdr message)
    (crdt--with-buffer-name
     buffer-name
     (let* ((key (cons site-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--format-message message) (process-get process '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 ,value))))
              (condition-case nil
                  (progn                ; filter non-readable object
                    (read-from-string message)
                    (crdt--broadcast-maybe message))
                (invalid-read-syntax)))))))
    (funcall orig-fun ov prop value)))

(cl-defmethod crdt-process-message ((message (head overlay-put)) process)
  (cl-destructuring-bind (buffer-name site-id logical-clock prop value) (cdr message)
    (crdt--with-buffer-name
     buffer-name
     (let ((ov (gethash (cons site-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--format-message message) (process-get process 'client-id)))

(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)

;;; Org integration

(define-minor-mode crdt-org-sync-overlay-mode ""
  nil " Sync Org Overlay" nil
  (if crdt-org-sync-overlay-mode
      (progn
        (save-excursion
          (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))

(provide 'crdt)
;;; crdt.el ends here